Session List_Update

Theory Inversion

section "List Inversion"

theory Inversion
imports "List-Index.List_Index"
begin

abbreviation "dist_perm xs ys  distinct xs  distinct ys  set xs = set ys"

definition before_in :: "'a  'a  'a list  bool"
  ("(_ </ _/ in _)" [55,55,55] 55) where
"x < y in xs = (index xs x < index xs y  y  set xs)"

definition Inv :: "'a list  'a list  ('a * 'a) set" where
"Inv xs ys = {(x,y). x < y in xs  y < x in ys}"

lemma before_in_setD1: "x < y in xs  x : set xs"
by (metis index_conv_size_if_notin index_less before_in_def less_asym order_refl)

lemma before_in_setD2: "x < y in xs  y : set xs"
by (simp add: before_in_def)


lemma not_before_in:
  "x : set xs  y : set xs  ¬ x < y in xs  y < x in xs  x=y"
by (metis index_eq_index_conv before_in_def less_asym linorder_neqE_nat)

lemma before_in_irefl: "x < x in xs = False"
by (meson before_in_setD2 not_before_in)

lemma no_before_inI[simp]: "x < y in xs  (¬ y < x in xs) = True"
by (metis before_in_setD1 not_before_in)

lemma finite_Invs[simp]:  "finite(Inv xs ys)"
apply(rule finite_subset[where B = "set xs × set ys"])
apply(auto simp add: Inv_def before_in_def)
apply(metis index_conv_size_if_notin index_less_size_conv less_asym)+
done

lemma Inv_id[simp]: "Inv xs xs = {}"
by(auto simp add: Inv_def before_in_def)

lemma card_Inv_sym: "card(Inv xs ys) = card(Inv ys xs)"
proof -
  have "Inv xs ys = (λ(x,y). (y,x)) ` Inv ys xs" by(auto simp: Inv_def)
  thus ?thesis by (metis card_image swap_inj_on)
qed

lemma Inv_tri_ineq:
  "dist_perm xs ys  dist_perm ys zs 
  Inv xs zs  Inv xs ys Un Inv ys zs"
by(auto simp: Inv_def) (metis before_in_setD1 not_before_in)

lemma card_Inv_tri_ineq:
  "dist_perm xs ys  dist_perm ys zs 
  card (Inv xs zs)  card(Inv xs ys) + card (Inv ys zs)"
using card_mono[OF _ Inv_tri_ineq[of xs ys zs]]
by auto (metis card_Un_Int finite_Invs trans_le_add1)

end

Theory Swaps

(* Author: Tobias Nipkow *)

section "Swapping Adjacent Elements in a List"

theory Swaps
imports Inversion
begin

text‹Swap elements at index n› and @{term "Suc n"}:›

definition "swap n xs =
  (if Suc n < size xs then xs[n := xs!Suc n, Suc n := xs!n] else xs)"

lemma length_swap[simp]: "length(swap i xs) = length xs"
by(simp add: swap_def)

lemma swap_id[simp]: "Suc n  size xs  swap n xs = xs"
by(simp add: swap_def)

lemma distinct_swap[simp]:
  "distinct(swap i xs) = distinct xs"
by(simp add: swap_def)

lemma swap_Suc[simp]: "swap (Suc n) (a # xs) = a # swap n xs"
by(induction xs) (auto simp: swap_def)

lemma index_swap_distinct:
  "distinct xs  Suc n < length xs 
  index (swap n xs) x =
  (if x = xs!n then Suc n else if x = xs!Suc n then n else index xs x)"
by(auto simp add: swap_def index_swap_if_distinct)

lemma set_swap[simp]: "set(swap n xs) = set xs"
by(auto simp add: swap_def set_conv_nth nth_list_update) metis

lemma nth_swap_id[simp]: "Suc i < length xs  swap i xs ! i = xs!(i+1)"
by(simp add: swap_def)

lemma before_in_swap:
 "dist_perm xs ys  Suc n < size xs 
  x < y in (swap n xs) 
  x < y in xs  ¬ (x = xs!n  y = xs!Suc n)  x = xs!Suc n  y = xs!n"
by(simp add:before_in_def index_swap_distinct)
  (metis Suc_lessD Suc_lessI index_less_size_conv index_nth_id less_Suc_eq n_not_Suc_n nth_index)

lemma Inv_swap: assumes "dist_perm xs ys"
shows "Inv xs (swap n ys) = 
  (if Suc n < size xs
   then if ys!n < ys!Suc n in xs
        then Inv xs ys  {(ys!n, ys!Suc n)}
        else Inv xs ys - {(ys!Suc n, ys!n)}
   else Inv xs ys)"
proof-
  have "length xs = length ys" using assms by (metis distinct_card)
  with assms show ?thesis
    by(simp add: Inv_def set_eq_iff)
      (metis before_in_def not_before_in before_in_swap)
qed


text‹Perform a list of swaps, from right to left:›

abbreviation swaps where "swaps == foldr swap"

lemma swaps_inv[simp]:
  "set (swaps sws xs) = set xs 
  size(swaps sws xs) = size xs 
  distinct(swaps sws xs) = distinct xs"
by (induct sws arbitrary: xs) (simp_all add: swap_def)

lemma swaps_eq_Nil_iff[simp]: "swaps acts xs = []  xs = []"
by(induction acts)(auto simp: swap_def)

lemma swaps_map_Suc[simp]:
  "swaps (map Suc sws) (a # xs) = a # swaps sws xs"
by(induction sws arbitrary: xs) auto

lemma card_Inv_swaps_le:
  "distinct xs  card (Inv xs (swaps sws xs))  length sws"
by(induction sws) (auto simp: Inv_swap card_insert_if card_Diff_singleton_if)

lemma nth_swaps: "iset is. j < i  swaps is xs ! j = xs ! j"
by(induction "is")(simp_all add: swap_def)

lemma not_before0[simp]: "~ x < xs ! 0 in xs"
apply(cases "xs = []")
by(auto simp: before_in_def neq_Nil_conv)

lemma before_id[simp]: " distinct xs; i < size xs; j < size xs  
  xs ! i < xs ! j in xs  i < j"
by(simp add: before_in_def index_nth_id)

lemma before_swaps:
  " distinct is; iset is. Suc i < size xs; distinct xs; i  set is; i < j; j < size xs  
  swaps is xs ! i < swaps is xs ! j in xs"
apply(induction "is" arbitrary: i j)
 apply simp
apply(auto simp: swap_def nth_list_update)
done

lemma card_Inv_swaps:
  " distinct is; iset is. Suc i < size xs; distinct xs  
  card(Inv xs (swaps is xs)) = length is"
apply(induction "is")
 apply simp
apply(simp add: Inv_swap before_swaps card_insert_if)
apply(simp add: Inv_def)
done

lemma swaps_eq_nth_take_drop: "i < length xs 
    swaps [0..<i] xs = xs!i # take i xs @ drop (Suc i) xs"
apply(induction i arbitrary: xs)
apply (auto simp add: neq_Nil_conv swap_def drop_update_swap
  take_Suc_conv_app_nth Cons_nth_drop_Suc[symmetric])
done

lemma index_swaps_size: "distinct s 
  index s q  index (swaps sws s) q + length sws"
apply(induction sws arbitrary: s)
apply simp
 apply (fastforce simp: swap_def index_swap_if_distinct index_nth_id)
done

lemma index_swaps_last_size: "distinct s 
  size s  index (swaps sws s) (last s) + length sws + 1"
apply(cases "s = []")
 apply simp
using index_swaps_size[of s "last s" sws] by simp

end

Theory On_Off

(* Author: Tobias Nipkow *)

section "Deterministic Online and Offline Algorithms"

theory On_Off
imports Complex_Main
begin

type_synonym ('s,'r,'a) alg_off = "'s  'r list  'a list"
type_synonym ('s,'is,'r,'a) alg_on = "('s  'is) * ('s * 'is  'r  'a * 'is)"

locale On_Off =
fixes step :: "'state  'request  'answer  'state"
fixes t :: "'state  'request  'answer  nat"
fixes wf :: "'state  'request list  bool"
begin

fun T :: "'state  'request list  'answer list  nat" where
"T s [] [] = 0" |
"T s (r#rs) (a#as) = t s r a + T (step s r a) rs as"

definition Step ::
  "('state , 'istate, 'request, 'answer)alg_on
    'state * 'istate  'request  'state * 'istate"
where
"Step A s r = (let (a,is') = snd A s r in (step (fst s) r a, is'))"

fun config' :: "('state,'is,'request,'answer) alg_on   ('state*'is)  'request list  
     ('state * 'is)" where
"config' A s []  = s" |
"config' A s (r#rs) = config' A (Step A s r) rs"

lemma config'_snoc: "config' A s (rs@[r]) = Step A (config' A s rs) r"
apply(induct rs arbitrary: s) by simp_all

lemma config'_append2: "config' A s (xs@ys) = config' A (config' A s xs) ys"
apply(induct xs arbitrary: s) by simp_all

lemma config'_induct: "P (fst init)  (s q a. P s  P (step s q a))
      P (fst (config' A init rs))"
apply (induct rs arbitrary: init) by(simp_all add: Step_def split: prod.split)

abbreviation config where
"config A s0 rs == config' A (s0, fst A s0) rs" 
 

lemma config_snoc: "config A s (rs@[r]) = Step A (config A s rs) r"
using config'_snoc by metis

lemma config_append: "config A s (xs@ys) = config' A (config A s xs) ys"
using config'_append2 by metis

lemma config_induct: "P s0  (s q a. P s  P (step s q a))  P (fst (config A s0 qs))"
using config'_induct[of P "(s0, fst A s0)" ] by auto

fun T_on' :: "('state,'is,'request,'answer) alg_on  ('state*'is)  'request list   nat" where
"T_on' A s [] = 0" |
"T_on' A s (r#rs) = (t (fst s) r (fst (snd A s r))) + T_on' A (Step A s r) rs"

lemma T_on'_append: "T_on' A s (xs@ys) = T_on' A s xs + T_on' A (config' A s xs) ys"
apply(induct xs arbitrary: s) by simp_all   

abbreviation T_on'' :: "('state,'is,'request,'answer) alg_on  'state  'request list  nat" where
  "T_on'' A s rs == T_on' A (s,fst A s) rs" 

lemma T_on_append: "T_on'' A s (xs@ys) = T_on'' A s xs + T_on' A (config A s xs) ys"
by(rule T_on'_append)  

abbreviation "T_on_n A s0 xs n == T_on' A (config A s0 (take n xs)) [xs!n]" 

lemma T_on__as_sum: "T_on'' A s0 rs = sum (T_on_n A s0 rs) {..<length rs} "
apply(induct rs rule: rev_induct)
  by(simp_all add: T_on'_append  nth_append)



fun off2 :: "('state,'is,'request,'answer) alg_on  ('state * 'is,'request,'answer) alg_off" where
"off2 A s [] = []" |
"off2 A s (r#rs) = fst (snd A s r) # off2 A (Step A s r) rs"


abbreviation off :: "('state,'is,'request,'answer) alg_on  ('state,'request,'answer) alg_off" where
"off A s0  off2 A (s0, fst A s0)"


abbreviation T_off :: "('state,'request,'answer) alg_off  'state  'request list  nat" where
"T_off A s0 rs == T s0 rs (A s0 rs)"



abbreviation T_on :: "('state,'is,'request,'answer) alg_on  'state  'request list  nat" where
"T_on A == T_off (off A)"



lemma T_on_on': "T_off (λs0. (off2 A (s0, x))) s0 qs = T_on' A (s0,x) qs"
apply(induct qs arbitrary: s0 x) 
  by(simp_all add: Step_def split: prod.split)

lemma T_on_on'': "T_on A s0 qs = T_on'' A s0 qs"
using T_on_on'[where x="fst A s0", of s0 qs A] by(auto)

lemma T_on_as_sum: "T_on A s0 rs = sum (T_on_n A s0 rs) {..<length rs} "
using T_on__as_sum T_on_on'' by metis



definition T_opt :: "'state  'request list  nat" where
"T_opt s rs = Inf {T s rs as | as. size as = size rs}"

definition compet :: "('state,'is,'request,'answer) alg_on  real  'state set  bool" where
"compet A c S = (sS. b  0. rs. wf s rs  real(T_on A s rs)  c * T_opt s rs + b)"

lemma length_off[simp]: "length(off2 A s rs) = length rs"
by (induction rs arbitrary: s) (auto split: prod.split)

lemma compet_mono: assumes "compet A c S0" and "c  c'"
shows "compet A c' S0"
proof (unfold compet_def, auto)
  let ?compt = "λs0 rs b (c::real). T_on A s0 rs  c * T_opt s0 rs + b"
  fix s0 assume "s0  S0"
  with assms(1) obtain b where "b  0" and 1: "rs. wf s0 rs  ?compt s0 rs b c"
    by(auto simp: compet_def)
  have "rs.  wf s0 rs  ?compt s0 rs b c'"
  proof safe
    fix rs
    assume wf: "wf s0 rs"
    from 1 wf have "?compt s0 rs b c" by blast
    thus "?compt s0 rs b c'"
      using 1 mult_right_mono[OF assms(2) of_nat_0_le_iff[of "T_opt s0 rs"]]
      by arith
  qed
  thus "b0. rs.  wf s0 rs  ?compt s0 rs b c'" using b0 by(auto)
qed

lemma competE: fixes c :: real
assumes "compet A c S0" "c  0" "s0 rs. size(aoff s0 rs) = length rs" "s0S0"
shows "b0. rs. wf s0 rs  T_on A s0 rs  c * T_off aoff s0 rs + b"
proof -
  from assms(1,4) obtain b where "b0" and
    1: "rs.  wf s0 rs  T_on A s0 rs  c * T_opt s0 rs + b"
    by(auto simp add: compet_def)
  { fix rs
    assume "wf s0 rs"
    then have 2: "real(T_on A s0 rs)  c * Inf {T s0 rs as | as. size as = size rs} + b"
      (is "_  _ * real(Inf ?T) + _")
      using 1 by(auto simp add: T_opt_def)
    have "Inf ?T  T_off aoff s0 rs"
      using assms(3) by (intro cInf_lower) auto
    from mult_left_mono[OF of_nat_le_iff[THEN iffD2, OF this] assms(2)]
    have "T_on A s0 rs  c * T_off aoff s0 rs + b" using 2 by arith
  }
  thus ?thesis using b0 by(auto simp: compet_def)
qed

end

end

Theory Prob_Theory

(*  Title:       Definition of Expectation and Distribution of uniformly distributed bit vectors
    Author:      Max Haslbeck
*)

section "Probability Theory"

theory Prob_Theory
imports "HOL-Probability.Probability"
begin

lemma integral_map_pmf[simp]:
  fixes f::"real  real"
  shows "(x. f x (map_pmf g M)) = (x. f (g x) M)"
   unfolding map_pmf_rep_eq
 using integral_distr[of g "(measure_pmf M)" "(count_space UNIV)" f] by auto


subsection "function E›"

definition E :: "real pmf  real"  where
  "E M = (x. x  measure_pmf M)"

translations
  " x. f M" <= "CONST lebesgue_integral M (λx. f)"

notation (latex output) E  ("E[_]" [1] 100)

lemma E_const[simp]: "E (return_pmf a) = a"
unfolding E_def
unfolding return_pmf.rep_eq
by (simp add: integral_return)

lemma E_null[simp]: "E (return_pmf 0) = 0"
by auto

lemma E_finite_sum: "finite (set_pmf X)  E X = (x(set_pmf X). pmf X x * x)"
  unfolding E_def by (subst integral_measure_pmf) simp_all

lemma E_of_const: "E(map_pmf (λx. y) (X::real pmf)) = y" by auto

lemma E_nonneg:
  shows "(xset_pmf X. 0 x)  0  E X"
unfolding E_def
using integral_nonneg by (simp add: AE_measure_pmf_iff integral_nonneg_AE)

lemma E_nonneg_fun: fixes f::"'areal"
  shows "(xset_pmf X. 0f x)  0  E (map_pmf f X)"
using E_nonneg by auto

lemma E_cong:
  fixes f::"'a  real"
  shows "finite (set_pmf X)  (x set_pmf X. (f x) = (u x))  E (map_pmf f X) = E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_cong_AE)
apply(simp add: integrable_measure_pmf_finite)+
by (simp add: AE_measure_pmf_iff)

lemma E_mono3:
  fixes f::"'a  real"
  shows " integrable (measure_pmf X) f   integrable (measure_pmf X) u  (x set_pmf X. (f x)  (u x))  E (map_pmf f X)  E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
by (auto simp add: AE_measure_pmf_iff)

lemma E_mono2:
  fixes f::"'a  real"
  shows "finite (set_pmf X)  (x set_pmf X. (f x)  (u x))  E (map_pmf f X)  E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
apply(simp add: integrable_measure_pmf_finite)+
by (simp add: AE_measure_pmf_iff)

lemma E_linear_diff2: "finite (set_pmf A)  E (map_pmf f A) - E (map_pmf g A) = E (map_pmf (λx. (f x) - (g x)) A)"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_diff[of "measure_pmf A" f g, symmetric])
 by (simp_all add: integrable_measure_pmf_finite)

lemma E_linear_plus2: "finite (set_pmf A)  E (map_pmf f A) + E (map_pmf g A) = E (map_pmf (λx. (f x) + (g x)) A)"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_add[of "measure_pmf A" f g, symmetric])
 by (simp_all add: integrable_measure_pmf_finite)

lemma E_linear_sum2: "finite (set_pmf D)  E(map_pmf (λx. (i<up. f i x)) D)
      = (i<(up::nat). E(map_pmf (f i) D))"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

lemma E_linear_sum_allg: "finite (set_pmf D)  E(map_pmf (λx. (i A. f i x)) D)
      = (i (A::'a set). E(map_pmf (f i) D))"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

lemma E_finite_sum_fun: "finite (set_pmf X) 
    E (map_pmf f X) = (xset_pmf X. pmf X x * f x)"
proof -
  assume finite: "finite (set_pmf X)"
  have "E (map_pmf f X) = (x. f x measure_pmf X)"
      unfolding E_def by auto
  also have " = (xset_pmf X. pmf X x * f x)"
    by (subst integral_measure_pmf) (auto simp add: finite)
  finally show ?thesis .
qed

lemma E_bernoulli: "0p  p1 
        E (map_pmf f (bernoulli_pmf p)) = p*(f True) + (1-p)*(f False)"
unfolding E_def by (auto)


subsection "function bv›"

  fun bv:: "nat  bool list pmf" where
  "bv 0 = return_pmf []"
| "bv (Suc n) =  do {
                    (xs::bool list)  bv n;
                    (x::bool)  (bernoulli_pmf 0.5);
                    return_pmf (x#xs)
                  }"

lemma bv_finite: "finite (bv n)"
by (induct  n) auto

lemma len_bv_n: "xs  set_pmf (bv n). length xs = n"
apply(induct n) by auto

lemma bv_set: "set_pmf (bv n) = {x::bool list. length x = n}"
proof (induct n)
  case (Suc n)
  then have "set_pmf (bv (Suc n)) = (x{x. length x = n}. {True # x, False # x})"
    by(simp add: set_pmf_bernoulli UNIV_bool)
  also have " = {x#xs| x xs. length xs = n}" by auto
  also have " = {x. length x = Suc n} " using Suc_length_conv by fastforce
  finally show ?case .
qed (simp)

lemma len_not_in_bv: "length xs   n  xs  set_pmf (bv n)"
by(auto simp: len_bv_n)

lemma not_n_bv_0: "length xs  n  pmf (bv n) xs = 0"
by (simp add: len_not_in_bv pmf_eq_0_set_pmf)

lemma bv_comp_bernoulli: "n < l
         map_pmf (λy. y!n) (bv l) = bernoulli_pmf (5 / 10)"
proof (induct n arbitrary: l)
  case 0
  then obtain m where "l = Suc m" by (metis Suc_pred)
  then show "map_pmf (λy. y!0) (bv l) =  bernoulli_pmf (5 / 10)" by (auto simp: map_pmf_def bind_return_pmf bind_assoc_pmf bind_return_pmf')
next
  case (Suc n)
  then have "0 < l" by auto
  then obtain m where lsm: "l = Suc m" by (metis Suc_pred)
  with Suc(2) have nltm: "n < m" by auto

  from lsm have "map_pmf (λy. y ! Suc n) (bv l)
       =  map_pmf (λx. x!n) (bind_pmf (bv m) (λt. (return_pmf t)))" by (auto simp: map_bind_pmf)
also
  have " =  map_pmf (λx. x!n) (bv m)" by (auto simp: bind_return_pmf')
also
  have " = bernoulli_pmf (5 / 10)" by (auto simp add: Suc(1)[of m, OF nltm])
finally
  show ?case .
qed

lemma pmf_2elemlist: "pmf (bv (Suc 0)) ([x]) = pmf (bv 0) [] * pmf (bernoulli_pmf (5 / 10)) x"
  unfolding bv.simps(2)[where n=0] pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{[]}"])
  apply (auto) by (cases x) auto

lemma pmf_moreelemlist: "pmf (bv (Suc n)) (x#xs) = pmf (bv n) xs * pmf (bernoulli_pmf (5 / 10)) x"
  unfolding bv.simps(2) pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{xs}"])
  apply auto apply (cases x) apply(auto)
  apply (meson indicator_simps(2) list.inject singletonD)
  apply (meson indicator_simps(2) list.inject singletonD)
  apply (cases x) by(auto)

lemma list_pmf: "length xs = n  pmf (bv n) xs = (1 / 2)^n"
proof(induct n arbitrary: xs)
  case 0
  then have "xs = []" by auto
  then show "pmf (bv 0) xs = (1 / 2) ^ 0" by(auto)
next
  case (Suc n xs)
  then obtain a as where split: "xs = a#as" by (metis Suc_length_conv)
  have "length as = n" using Suc(2) split by auto
  with Suc(1) have 1: "pmf (bv n) as = (1 / 2) ^ n" by auto

  from split pmf_moreelemlist[where n=n and x=a and xs=as] have
    "pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
  then have "pmf (bv (Suc n)) xs = (1 / 2) ^ n * 1 / 2" using 1 by auto
  then show "pmf (bv (Suc n)) xs = (1 / 2) ^ Suc n" by auto
qed

lemma bv_0_notlen: "pmf (bv n) xs = 0  length xs  n "
by(auto simp: list_pmf)

lemma "length xs > n  pmf (bv n) xs = 0"
proof (induct n arbitrary: xs)
  case (Suc n xs)
  then obtain a as where split: "xs = a#as" by (metis Suc_length_conv Suc_lessE)
  have "length as > n" using Suc(2) split by auto
  with Suc(1) have 1: "pmf (bv n) as = 0" by auto
  from split pmf_moreelemlist[where n=n and x=a and xs=as] have
    "pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
  then have "pmf (bv (Suc n)) xs = 0 * 1 / 2" using 1 by auto
  then show "pmf (bv (Suc n)) xs = 0" by auto
qed simp

lemma map_hd_list_pmf: "map_pmf hd (bv (Suc n)) = bernoulli_pmf (5 / 10)"
  by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf')

lemma map_tl_list_pmf: "map_pmf tl (bv (Suc n)) = bv n"
  by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf' )


subsection "function flip›"

fun flip :: "nat  bool list  bool list" where
  "flip _ [] = []"
| "flip 0 (x#xs) = (¬x)#xs"
| "flip (Suc n) (x#xs) = x#(flip n xs)"

lemma flip_length[simp]: "length (flip i xs) = length xs"
apply(induct xs arbitrary: i) apply(simp) apply(case_tac i) by(simp_all)

lemma flip_out_of_bounds: "y  length X  flip y X = X"
apply(induct X arbitrary: y)
proof -
  case (Cons X Xs)
  hence "y > 0" by auto
  with Cons obtain y' where y1: "y = Suc y'" and y2: "y'  length Xs" by (metis Suc_pred' length_Cons not_less_eq_eq)
  then have "flip y (X # Xs) = X#(flip y' Xs)" by auto
  moreover from Cons y2 have "flip y' Xs = Xs" by auto
  ultimately show ?case by auto
qed simp

lemma flip_other: "y < length X  z < length X  z  y  flip z X ! y = X ! y"
apply(induct y arbitrary: X z)
apply(simp) apply (metis flip.elims neq0_conv nth_Cons_0)
proof (case_tac z, goal_cases)
  case (1 y X z)
  then obtain a as where "X=a#as" using length_greater_0_conv by (metis (full_types) flip.elims)
  with 1(5) show ?case by(simp)
next
  case (2 y X z z')
  from 2 have 3: "z'  y" by auto
  from 2(2) have "length X > 0" by auto
  then obtain a as where aas: "X = a#as" by (metis (full_types) flip.elims length_greater_0_conv)
  then have a: "flip (Suc z') X ! Suc y = flip z' as ! y"
    and b : "(X ! Suc y) = (as !  y)" by auto
  from 2(2) aas have 1: "y < length as" by auto
  from 2(3,5) aas have f2: "z' < length as" by auto
  note c=2(1)[OF 1 f2 3]

  have "flip z X ! Suc y = flip (Suc z') X ! Suc y" using 2 by auto
  also have " = flip z' as ! y" by (rule a)
  also have " = as ! y" by (rule c)
  also have " = (X ! Suc y)" by (rule b[symmetric])
  finally show "flip z X ! Suc y = (X ! Suc y)" .
qed

lemma flip_itself: "y < length X  flip y X ! y = (¬ X ! y)"
apply(induct y arbitrary: X)
apply(simp) apply (metis flip.elims nth_Cons_0 old.nat.distinct(2))
proof -
  fix y
  fix X::"bool list"
  assume iH: "(X. y < length X  flip y X ! y = (¬ X ! y))"
  assume len: "Suc y < length X"
  from len have "y < length X" by auto
  from len have "length X > 0" by auto
  then obtain z zs where zzs: "X = z#zs" by (metis (full_types) flip.elims length_greater_0_conv)
  then have a: "flip (Suc y) X ! Suc y = flip y zs ! y"
    and b : "(¬ X ! Suc y) = (¬ zs !  y)" by auto
  from len zzs have "y < length zs" by auto
  note c=iH[OF this]
  from a b c show "flip (Suc y) X ! Suc y = (¬ X ! Suc y)" by auto
qed

lemma flip_twice: "flip i (flip i b) = b"
proof (cases "i < length b")
  case True
  then have A: "i < length (flip i b)" by simp
  show ?thesis apply(simp add: list_eq_iff_nth_eq) apply(clarify)
  proof (goal_cases)
    case (1 j)
    then show ?case
      apply(cases "i=j")
        using flip_itself[OF A] flip_itself[OF True] apply(simp)
        using flip_other True 1 by auto
  qed
qed (simp add: flip_out_of_bounds)

lemma flipidiflip: "y < length X  e < length X   flip e X ! y = (if e=y then ~ (X ! y) else X ! y)"
apply(cases "e=y")
apply(simp add: flip_itself)
by(simp add: flip_other)

lemma bernoulli_Not: "map_pmf Not (bernoulli_pmf (1 / 2)) = (bernoulli_pmf (1 / 2))"
apply(rule pmf_eqI)
proof (case_tac i, goal_cases)
  case (1 i)
  then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
    pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not False)" by auto
  also have " = pmf (bernoulli_pmf (1 / 2)) False" apply (rule pmf_map_inj') apply(rule injI) by auto
  also have " = pmf (bernoulli_pmf (1 / 2)) i" by auto
  finally show ?case .
next
  case (2 i)
  then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
    pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not True)" by auto
  also have " = pmf (bernoulli_pmf (1 / 2)) True" apply (rule pmf_map_inj') apply(rule injI) by auto
  also have " = pmf (bernoulli_pmf (1 / 2)) i" by auto
  finally show ?case .
qed

lemma inv_flip_bv: "map_pmf (flip i) (bv n) = (bv n)"
proof(induct n arbitrary: i)
   case (Suc n i)
   note iH=this
   have "bind_pmf (bv n) (λx. bind_pmf (bernoulli_pmf (1 / 2)) (λxa. map_pmf (flip i) (return_pmf (xa # x))))
    = bind_pmf (bernoulli_pmf (1 / 2)) (λxa .bind_pmf (bv n) (λx. map_pmf (flip i) (return_pmf (xa # x))))"
    by(rule bind_commute_pmf)
   also have " = bind_pmf (bernoulli_pmf (1 / 2)) (λxa . bind_pmf (bv n) (λx. return_pmf (xa # x)))"
   proof (cases i)
    case 0
    then have "bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. map_pmf (flip i) (return_pmf (xa # x))))
        = bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. return_pmf ((¬ xa) # x)))" by auto
    also have "  = bind_pmf (bv n) (λx. bind_pmf (bernoulli_pmf (1 / 2)) (λxa. return_pmf ((¬ xa) # x)))"
      by(rule bind_commute_pmf)
    also have "
        = bind_pmf (bv n) (λx. bind_pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (λxa. return_pmf (xa # x)))"
              by(auto simp add: bind_map_pmf)
    also have " = bind_pmf (bv n) (λx. bind_pmf (bernoulli_pmf (1 / 2)) (λxa. return_pmf (xa # x)))" by (simp only: bernoulli_Not)
    also have " = bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. return_pmf (xa # x)))"
      by(rule bind_commute_pmf)
    finally show ?thesis .
   next
    case (Suc i')
    have "bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. map_pmf (flip i) (return_pmf (xa # x))))
        = bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. return_pmf (xa # flip i' x)))" unfolding Suc by(simp)
    also have " = bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (map_pmf (flip i') (bv n)) (λx. return_pmf (xa # x)))"
        by(auto simp add: bind_map_pmf)
    also have " =  bind_pmf (bernoulli_pmf (1 / 2)) (λxa. bind_pmf (bv n) (λx. return_pmf (xa # x)))"
        using iH[of "i'"] by simp
    finally show ?thesis .
   qed
   also have " = bind_pmf (bv n) (λx. bind_pmf (bernoulli_pmf (1 / 2)) (λxa. return_pmf (xa # x)))"
    by(rule bind_commute_pmf)
   finally show ?case by(simp add: map_pmf_def bind_assoc_pmf)
qed simp


subsection "Example for pmf"

definition "twocoins =
                do {
                    x  (bernoulli_pmf 0.4);
                    y  (bernoulli_pmf 0.5);
                    return_pmf (x  y)
                  }"

lemma experiment0_7: "pmf twocoins True = 0.7"
unfolding twocoins_def
  unfolding pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{True, False}"])
  by auto

subsection "Sum Distribution"

definition "Sum_pmf p Da Db = (bernoulli_pmf p)  (%b. if b then map_pmf Inl Da else map_pmf Inr Db )"

lemma b0: "bernoulli_pmf 0 = return_pmf False"
apply(rule pmf_eqI) apply(case_tac i)
  by(simp_all)
lemma b1: "bernoulli_pmf 1 = return_pmf True"
apply(rule pmf_eqI) apply(case_tac i)
  by(simp_all)


lemma Sum_pmf_0: "Sum_pmf 0 Da Db = map_pmf Inr Db"
unfolding Sum_pmf_def
apply(rule pmf_eqI)
  by(simp add: b0 bind_return_pmf)

lemma Sum_pmf_1: "Sum_pmf 1 Da Db = map_pmf Inl Da"
unfolding Sum_pmf_def
apply(rule pmf_eqI)
  by(simp add: b1 bind_return_pmf)


definition "Proj1_pmf D = map_pmf (%a. case a of Inl e  e) (cond_pmf D {f. (e. Inl e = f)})"


lemma A: "(case_sum (λe. e) (λa. undefined)) (Inl e) = e"
  by(simp)

lemma B: "inj (case_sum (λe. e) (λa. undefined))"
  oops

lemma none: "p >0  p < 1  (set_pmf (bernoulli_pmf p 
          (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. (e. Inl e = f)})  {}"
    apply(simp add: UNIV_bool)
      using set_pmf_not_empty by fast
lemma none2: "p >0  p < 1   (set_pmf (bernoulli_pmf p 
          (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. (e. Inr e = f)})  {}"
    apply(simp add: UNIV_bool)
      using set_pmf_not_empty by fast

lemma C: "set_pmf (Proj1_pmf (Sum_pmf 0.5 Da Db)) = set_pmf Da"
proof -
  show ?thesis
    unfolding Sum_pmf_def Proj1_pmf_def
    apply(simp add: )
    using none[of "0.5" Da Db] apply(simp add: set_cond_pmf UNIV_bool)
      by force
qed

thm integral_measure_pmf

thm pmf_cond pmf_cond[OF none]

lemma proj1_pmf: assumes "p>0" "p<1" shows "Proj1_pmf (Sum_pmf p Da Db) =  Da"
proof -

  have kl: "e. pmf (map_pmf Inr Db) (Inl e) = 0"
    apply(simp only: pmf_eq_0_set_pmf)
    apply(simp) by blast

  have ll: "measure_pmf.prob
           (bernoulli_pmf p 
            (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. e. Inl e = f} = p"
       using assms
     apply(simp add: integral_pmf[symmetric] pmf_bind)
     apply(subst Bochner_Integration.integral_add)
      using integrable_pmf apply fast
      using integrable_pmf apply fast
        by(simp add: integral_pmf)

  have E: "(cond_pmf
       (bernoulli_pmf p 
        (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
       {f. e. Inl e = f}) =
    map_pmf Inl Da"
    apply(rule pmf_eqI)
      apply(subst pmf_cond)
      using none[of p Da Db] assms apply (simp)
       using assms apply(auto)
          apply(subst pmf_bind)
          apply(simp add: kl ll )
          apply(simp only: pmf_eq_0_set_pmf) by auto

  have ID: "case_sum (λe. e) (λa. undefined)  Inl = id"
    by fastforce
  show ?thesis
    unfolding Sum_pmf_def Proj1_pmf_def
    apply(simp only: E)
    apply(simp add: pmf.map_comp ID)
  done

qed


definition "Proj2_pmf D = map_pmf (%a. case a of Inr e  e) (cond_pmf D {f. (e. Inr e = f)})"

lemma proj2_pmf: assumes "p>0" "p<1" shows "Proj2_pmf (Sum_pmf p Da Db) =  Db"
proof -

  have kl: "e. pmf (map_pmf Inl Da) (Inr e) = 0"
    apply(simp only: pmf_eq_0_set_pmf)
    apply(simp) by blast

  have ll: "measure_pmf.prob
           (bernoulli_pmf p 
            (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. e. Inr e = f} = 1-p"
       using assms
     apply(simp add: integral_pmf[symmetric] pmf_bind)
     apply(subst Bochner_Integration.integral_add)
      using integrable_pmf apply fast
      using integrable_pmf apply fast
        by(simp add: integral_pmf)

  have E: "(cond_pmf
       (bernoulli_pmf p 
        (λb. if b then map_pmf Inl Da else map_pmf Inr Db))
       {f. e. Inr e = f}) =
    map_pmf Inr Db"
    apply(rule pmf_eqI)
      apply(subst pmf_cond)
      using none2[of p Da Db] assms apply (simp)
       using assms apply(auto)
          apply(subst pmf_bind)
          apply(simp add: kl ll )
          apply(simp only: pmf_eq_0_set_pmf) by auto

  have ID: "case_sum (λe. undefined) (λa. a)  Inr = id"
    by fastforce
  show ?thesis
    unfolding Sum_pmf_def Proj2_pmf_def
    apply(simp only: E)
    apply(simp add: pmf.map_comp ID)
  done

qed




definition "invSum invA invB D x i == invA (Proj1_pmf D) x i  invB (Proj2_pmf D) x i"


lemma invSum_split: "p>0  p<1  invA Da x i  invB Db x i  invSum invA invB (Sum_pmf p Da Db) x i"
by(simp add: invSum_def proj1_pmf proj2_pmf)

term "(%a. case a of Inl e  Inl (fa e) | Inr e  Inr (fb e))"
definition "f_on2 fa fb = (%a. case a of Inl e  map_pmf Inl (fa e) | Inr e  map_pmf Inr (fb e))"

term "bind_pmf"


lemma Sum_bind_pmf: assumes a: "bind_pmf Da fa = Da'" and b: "bind_pmf Db fb = Db'"
  shows "bind_pmf (Sum_pmf p Da Db) (f_on2 fa fb)
              = Sum_pmf p Da' Db'"
proof -
  { fix x
  have "(if x then map_pmf Inl Da else map_pmf Inr Db) 
                 case_sum (λe. map_pmf Inl (fa e))
                  (λe. map_pmf Inr (fb e))
            =
        (if x then map_pmf Inl Da  case_sum (λe. map_pmf Inl (fa e))
                  (λe. map_pmf Inr (fb e))
              else map_pmf Inr Db  case_sum (λe. map_pmf Inl (fa e))
                  (λe. map_pmf Inr (fb e)))"
                  apply(simp) done
  also
    have " = (if x then map_pmf Inl (bind_pmf Da fa) else map_pmf Inr (bind_pmf Db fb))"
      by(auto simp add: map_pmf_def bind_assoc_pmf bind_return_pmf)
  also
    have " = (if x then map_pmf Inl Da' else map_pmf Inr Db')"
      using a b by simp
  finally
    have "(if x then map_pmf Inl Da else map_pmf Inr Db) 
                 case_sum (λe. map_pmf Inl (fa e))
                  (λe. map_pmf Inr (fb e)) = (if x then map_pmf Inl Da' else map_pmf Inr Db')" .
  } note gr=this



  show ?thesis
    unfolding Sum_pmf_def f_on2_def
    apply(rule pmf_eqI)
    apply(case_tac i)
    by(simp_all add: bind_return_pmf bind_assoc_pmf gr)
qed

definition "sum_map_pmf fa fb = (%a. case a of Inl e  Inl (fa e) | Inr e  Inr (fb e))"

lemma Sum_map_pmf: assumes a: "map_pmf fa Da = Da'" and b: "map_pmf fb Db = Db'"
  shows "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
              = Sum_pmf p Da' Db'"
proof -
  have "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
        = bind_pmf (Sum_pmf p Da Db) (f_on2 (λx. return_pmf (fa x)) (λx. return_pmf (fb x)))"
        using a b
  unfolding map_pmf_def sum_map_pmf_def f_on2_def
    by(auto simp add: bind_return_pmf sum.case_distrib)
also
  have " = Sum_pmf p Da' Db'"
 using assms[unfolded map_pmf_def]
 by(rule Sum_bind_pmf )
finally
  show ?thesis .
qed



end

Theory Competitive_Analysis

(*  Title:       The Framework for competitive Analysis of randomized online algorithms
    Author:      Tobias Nipkow
                 Max Haslbeck
*)

section "Randomized Online and Offline Algorithms"

theory Competitive_Analysis
imports
  Prob_Theory
  On_Off
begin
 


subsection "Competitive Analysis Formalized"
 
type_synonym ('s,'is,'r,'a)alg_on_step = "('s * 'is   'r  ('a * 'is) pmf)"
type_synonym ('s,'is)alg_on_init = "('s  'is pmf)"
type_synonym ('s,'is,'q,'a)alg_on_rand = "('s,'is)alg_on_init * ('s,'is,'q,'a)alg_on_step"

subsubsection "classes of algorithms"


definition deterministic_init :: "('s,'is)alg_on_init  bool" where
  "deterministic_init I  (init. card( set_pmf (I init)) = 1)"

definition deterministic_step :: "('s,'is,'q,'a)alg_on_step  bool" where
  "deterministic_step S  (i is q. card( set_pmf (S (i, is) q)) = 1)"

definition random_step :: "('s,'is,'q,'a)alg_on_step  bool" where
  "random_step S  ~ deterministic_step S"

 
subsubsection "Randomized Online and Offline Algorithms"

context On_Off
begin

  

fun steps where
  "steps s [] [] = s"
| "steps s (q#qs) (a#as) = steps (step s q a) qs as"

lemma steps_append: "length qs = length as  steps s (qs@qs') (as@as') = steps (steps s qs as) qs' as'"
apply(induct qs as arbitrary: s rule: list_induct2)
   by simp_all


lemma T_append: "length qs = length as  T s (qs@[q]) (as@[a]) = T s qs as + t (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2)
   by simp_all


lemma T_append2: "length qs = length as  T s (qs@qs') (as@as') = T s qs as + T (steps s qs as) qs' as'"
apply(induct qs as arbitrary: s rule: list_induct2)
   by simp_all

abbreviation Step_rand :: "('state,'is,'request,'answer) alg_on_rand   'request  'state * 'is  ('state * 'is) pmf" where
"Step_rand A r s  bind_pmf ((snd A) s r) (λ(a,is'). return_pmf (step (fst s) r a, is'))"
 
fun config'_rand :: "('state,'is,'request,'answer) alg_on_rand   ('state*'is) pmf  'request list  
     ('state * 'is) pmf" where
"config'_rand A s []  = s" |
"config'_rand A s (r#rs) = config'_rand A (s  Step_rand A r) rs"

lemma config'_rand_snoc: "config'_rand A s (rs@[r]) = config'_rand A s rs  Step_rand A r"
apply(induct rs arbitrary: s) by(simp_all)

lemma config'_rand_append: "config'_rand A s (xs@ys) = config'_rand A (config'_rand A s xs) ys"
apply(induct xs arbitrary: s) by(simp_all)


abbreviation config_rand where
"config_rand A s0 rs == config'_rand A ((fst A s0)  (λis. return_pmf (s0, is))) rs"

lemma config'_rand_induct: "(x  set_pmf init. P (fst x))  (s q a. P s  P (step s q a))
      xset_pmf (config'_rand A init qs). P (fst x)"
proof (induct qs arbitrary: init)
  case (Cons r rs)
  show ?case apply(simp)
    apply(rule Cons(1))
      apply(subst Set.ball_simps(9)[where P=P, symmetric])
      apply(subst set_map_pmf[symmetric])   
      apply(simp only: map_bind_pmf)
      apply(simp add: bind_assoc_pmf bind_return_pmf split_def)
      using Cons(2,3) apply blast
      by fact
qed (simp)
 
lemma config_rand_induct: "P s0  (s q a. P s  P (step s q a))  xset_pmf (config_rand A s0 qs). P (fst x)"
using config'_rand_induct[of "((fst A s0)  (λis. return_pmf (s0, is)))" P] by auto


fun T_on_rand' :: "('state,'is,'request,'answer) alg_on_rand  ('state*'is) pmf  'request list   real" where
"T_on_rand' A s [] = 0" |
"T_on_rand' A s (r#rs) = E ( s  (λs. bind_pmf (snd A s r) (λ(a,is'). return_pmf (real (t (fst s) r a)))) )
                              + T_on_rand' A (s  Step_rand A r) rs"


lemma T_on_rand'_append: "T_on_rand' A s (xs@ys) = T_on_rand' A s xs + T_on_rand' A (config'_rand A s xs) ys"
apply(induct xs arbitrary: s) by simp_all   

abbreviation T_on_rand :: "('state,'is,'request,'answer) alg_on_rand  'state  'request list  real" where
  "T_on_rand A s rs == T_on_rand' A (fst A s  (λis. return_pmf (s,is))) rs" 

lemma T_on_rand_append: "T_on_rand A s (xs@ys) = T_on_rand A s xs + T_on_rand' A (config_rand A s xs) ys"
by(rule T_on_rand'_append)  


abbreviation "T_on_rand'_n A s0 xs n == T_on_rand' A (config'_rand A s0 (take n xs)) [xs!n]"

lemma T_on_rand'_as_sum: "T_on_rand' A s0 rs = sum (T_on_rand'_n A s0 rs) {..<length rs} "
apply(induct rs rule: rev_induct)
  by(simp_all add: T_on_rand'_append nth_append)


abbreviation "T_on_rand_n A s0 xs n == T_on_rand' A (config_rand A s0 (take n xs)) [xs!n]" 

lemma T_on_rand_as_sum: "T_on_rand A s0 rs = sum (T_on_rand_n A s0 rs) {..<length rs} "
apply(induct rs rule: rev_induct)
  by(simp_all add: T_on_rand'_append  nth_append)


lemma T_on_rand'_nn: "T_on_rand' A s qs  0"
apply(induct qs arbitrary: s) 
  apply(simp_all add: bind_return_pmf)
  apply(rule add_nonneg_nonneg)
  apply(rule E_nonneg) 
    by(simp_all add: split_def) 

lemma T_on_rand_nn: "T_on_rand (I,S) s0 qs  0"
by (rule T_on_rand'_nn)
 
definition compet_rand :: "('state,'is,'request,'answer) alg_on_rand  real  'state set  bool" where
"compet_rand A c S0 = (sS0. b  0. rs. wf s rs  T_on_rand A s rs  c * T_opt s rs + b)"


subsection "embeding of deterministic into randomized algorithms"

fun embed :: "('state,'is,'request,'answer) alg_on  ('state,'is,'request,'answer) alg_on_rand" where
"embed A = ( (λs. return_pmf (fst A s))  ,
                  (λs r. return_pmf (snd A s r)) )"

lemma T_deter_rand: "T_off (λs0. (off2 A (s0, x))) s0 qs = T_on_rand' (embed A) (return_pmf (s0,x)) qs"
apply(induct qs arbitrary: s0 x) 
  by(simp_all add: Step_def bind_return_pmf split: prod.split)


lemma config'_embed: "config'_rand (embed A) (return_pmf s0) qs = return_pmf (config' A s0 qs)"
apply(induct qs arbitrary: s0)
  apply(simp_all add: Step_def split_def bind_return_pmf) by metis

lemma config_embed: "config_rand (embed A) s0 qs = return_pmf (config A s0 qs)" 
apply(simp add: bind_return_pmf)
  apply(subst config'_embed[unfolded embed.simps])
    by simp

lemma T_on_embed: "T_on A s0 qs = T_on_rand (embed A) s0 qs"
using T_deter_rand[where x="fst A s0", of s0 qs A] by(auto simp: bind_return_pmf)


lemma T_on'_embed: "T_on' A (s0,x) qs = T_on_rand' (embed A) (return_pmf (s0,x)) qs"
using T_deter_rand T_on_on' by metis
 

lemma compet_embed: "compet A c S0 = compet_rand (embed A) c S0"
unfolding compet_def compet_rand_def using T_on_embed by metis

 
   
end 



end 

Theory Move_to_Front

(* Author: Tobias Nipkow *)

section "Deterministic List Update"

theory Move_to_Front
imports
  Swaps
  On_Off
  Competitive_Analysis
begin

declare Let_def[simp]

subsection "Function mtf›"

definition mtf :: "'a  'a list  'a list" where
"mtf x xs =
 (if x  set xs then x # (take (index xs x) xs) @ drop (index xs x + 1) xs
  else xs)"

lemma mtf_id[simp]: "x  set xs  mtf x xs = xs"
by(simp add: mtf_def)

lemma mtf0[simp]: "x  set xs  mtf x xs ! 0 = x"
by(auto simp: mtf_def)

lemma before_in_mtf: assumes "z  set xs"
shows "x < y in mtf z xs  
      (y  z  (if x=z then y  set xs else x < y in xs))"
proof-
  have 0: "index xs z < size xs" by (metis assms index_less_size_conv)
  let ?xs = "take (index xs z) xs @ xs ! index xs z # drop (Suc (index xs z)) xs"
  have "x < y in mtf z xs = (y  z  (if x=z then y  set ?xs else x < y in ?xs))"
    using assms
    by(auto simp add: mtf_def before_in_def index_append)
      (metis add_lessD1 index_less_size_conv length_take less_Suc_eq not_less_eq)
  with id_take_nth_drop[OF 0, symmetric] show ?thesis by(simp)
qed

lemma Inv_mtf: "set xs = set ys  z : set ys  Inv xs (mtf z ys) =
 Inv xs ys  {(x,z)|x. x < z in xs  x < z in ys}
 - {(z,x)|x. z < x in xs  x < z in ys}"
by(auto simp add: Inv_def before_in_mtf not_before_in dest: before_in_setD1)

lemma set_mtf[simp]: "set(mtf x xs) = set xs"
by(simp add: mtf_def)
  (metis append_take_drop_id Cons_nth_drop_Suc index_less le_refl Un_insert_right nth_index set_append set_simps(2))

lemma length_mtf[simp]: "size (mtf x xs) = size xs"
by (auto simp add: mtf_def min_def) (metis index_less_size_conv leD)

lemma distinct_mtf[simp]: "distinct (mtf x xs) = distinct xs"
by (metis length_mtf set_mtf card_distinct distinct_card)


subsection "Function mtf2›"

definition mtf2 :: "nat  'a  'a list  'a list" where
"mtf2 n x xs =
 (if x : set xs then swaps [index xs x - n..<index xs x] xs else xs)"

lemma mtf_eq_mtf2: "mtf x xs = mtf2 (length xs - 1) x xs"
proof -
  have "x : set xs  index xs x - (size xs - Suc 0) = 0"
    by (auto simp: less_Suc_eq_le[symmetric])
  thus ?thesis
    by(auto simp: mtf_def mtf2_def swaps_eq_nth_take_drop)
qed

lemma mtf20[simp]: "mtf2 0 x xs = xs"
by(auto simp add: mtf2_def)

lemma length_mtf2[simp]: "length (mtf2 n x xs) = length xs"
by (auto simp: mtf2_def index_less_size_conv[symmetric]
  simp del:index_conv_size_if_notin)

lemma set_mtf2[simp]: "set(mtf2 n x xs) = set xs"
by (auto simp: mtf2_def index_less_size_conv[symmetric]
  simp del:index_conv_size_if_notin)

lemma distinct_mtf2[simp]: "distinct (mtf2 n x xs) = distinct xs"
by (metis length_mtf2 set_mtf2 card_distinct distinct_card)

lemma card_Inv_mtf2: "xs!j = ys!0  j < length xs  dist_perm xs ys 
   card (Inv (swaps [i..<j] xs) ys) = card (Inv xs ys) - int(j-i)"
proof(induction j arbitrary: xs)
  case (Suc j)
  show ?case
  proof cases
    assume "i > j" thus ?thesis by simp
  next
    assume [arith]: "¬ i > j"
    have 0: "Suc j < length ys" by (metis Suc.prems(2,3) distinct_card)
    have 1: "(ys ! 0, xs ! j) : Inv ys xs"
    proof (auto simp: Inv_def)
      show "ys ! 0 < xs ! j in ys" using Suc.prems
        by (metis Suc_lessD n_not_Suc_n not_before0 not_before_in nth_eq_iff_index_eq nth_mem)
      show "xs ! j < ys ! 0 in xs" using Suc.prems
        by (metis Suc_lessD before_id lessI)
    qed
    have 2: "card(Inv ys xs)  0" using 1 by auto
    have "int(card (Inv (swaps [i..<Suc j] xs) ys)) =
          card (Inv (swap j xs) ys) - int (j-i)" using Suc by simp
    also have " = card (Inv ys (swap j xs)) - int (j-i)"
      by(simp add: card_Inv_sym)
    also have " = card (Inv ys xs - {(ys ! 0, xs ! j)}) - int (j - i)"
      using Suc.prems 0 by(simp add: Inv_swap)
    also have " = int(card (Inv ys xs) - 1) - (j - i)"
      using 1 by(simp add: card_Diff_singleton)
    also have " = card (Inv ys xs) - int (Suc j - i)" using 2 by arith
    also have " = card (Inv xs ys) - int (Suc j - i)" by(simp add: card_Inv_sym)
    finally show ?thesis .
  qed
qed simp





subsection "Function Lxy"


definition Lxy :: "'a list  'a set  'a list" where
  "Lxy xs S = filter (λz. zS) xs" 
thm inter_set_filter

lemma Lxy_length_cons: "length (Lxy xs S)  length (Lxy (x#xs) S)"
unfolding Lxy_def by(simp)

lemma Lxy_empty[simp]: "Lxy [] S = []"
unfolding Lxy_def by simp

lemma Lxy_set_filter: "set (Lxy xs S) = S  set xs" 
by (simp add: Lxy_def inter_set_filter)

lemma Lxy_distinct: "distinct xs  distinct (Lxy xs S)"
by (simp add: Lxy_def)

lemma Lxy_append: "Lxy (xs@ys) S = Lxy xs S @ Lxy ys S"
by(simp add: Lxy_def)

lemma Lxy_snoc: "Lxy (xs@[x]) S = (if xS then Lxy xs S @ [x] else Lxy xs S)"
by(simp add: Lxy_def)

lemma Lxy_not: "S  set xs = {}  Lxy xs S = []"
unfolding Lxy_def apply(induct xs) by simp_all



lemma Lxy_notin: "set xs  S = {}  Lxy xs S = []"
apply(induct xs) by(simp_all add: Lxy_def)

lemma Lxy_in: "xS  Lxy [x] S = [x]"
by(simp add: Lxy_def)



lemma Lxy_project: 
  assumes "xy" "x  set xs"  "yset xs" "distinct xs" 
    and "x < y in xs"
  shows "Lxy xs {x,y} = [x,y]"
proof -
  from assms have ij: "index xs x < index xs y"
        and xinxs: "index xs x < length xs"
        and yinxs: "index xs y < length xs" unfolding before_in_def by auto  
  from xinxs obtain a as where dec1: "a @ [xs!index xs x] @ as = xs"
        and "a = take (index xs x) xs" and "as = drop (Suc (index xs x)) xs"
        and length_a: "length a = index xs x" and length_as: "length as = length xs - index xs x- 1"
        using id_take_nth_drop by fastforce 
  have "index xs ylength (a @ [xs!index xs x])" using length_a ij by auto
  then have "((a @ [xs!index xs x]) @ as) ! index xs y = as ! (index xs y-length (a @ [xs ! index xs x]))" using nth_append[where xs="a @ [xs!index xs x]" and ys="as"]
    by(simp)
  then have xsj: "xs ! index xs y = as ! (index xs y-index xs x-1)" using dec1 length_a by auto   
  have las: "(index xs y-index xs x-1) < length as" using length_as yinxs ij by simp
  obtain b c where dec2: "b @ [xs!index xs y] @ c = as"
            and "b = take (index xs y-index xs x-1) as" "c=drop (Suc (index xs y-index xs x-1)) as"
            and length_b: "length b = index xs y-index xs x-1" using id_take_nth_drop[OF las] xsj by force
  have xs_dec: "a @ [xs!index xs x] @ b @ [xs!index xs y] @ c = xs" using dec1 dec2 by auto 
   
  from xs_dec assms(4) have "distinct ((a @ [xs!index xs x] @ b @ [xs!index xs y]) @ c)" by simp
  then have c_empty: "set c  {x,y} = {}"
      and b_empty: "set b  {x,y} = {}"and a_empty: "set a  {x,y} = {}" by(auto simp add: assms(2,3))

  have "Lxy (a @ [xs!index xs x] @ b @ [xs!index xs y] @ c) {x,y} = [x,y]"
    apply(simp only: Lxy_append)
    apply(simp add: assms(2,3))
    using a_empty b_empty c_empty by(simp add: Lxy_notin Lxy_in)

  with xs_dec show ?thesis by auto
qed


lemma Lxy_mono: "{x,y}  set xs  distinct xs  x < y in xs = x < y in Lxy xs {x,y}"
apply(cases "x=y")
  apply(simp add: before_in_irefl)
proof -
  assume xyset: "{x,y}  set xs"
  assume dxs: "distinct xs"
  assume xy: "xy" 
  {
    fix x y
    assume 1: "{x,y}  set xs" 
    assume xny: "xy"
    assume 3: "x < y in xs" 
    have "Lxy xs {x,y} = [x,y]" apply(rule Lxy_project) 
          using xny 1 3 dxs by(auto)
    then have "x < y in Lxy xs {x,y}" using xny by(simp add: before_in_def)
  } note aha=this
  have a: "x < y in xs  x < y in Lxy xs {x,y}"
    apply(subst Lxy_project) 
      using xy xyset dxs by(simp_all add: before_in_def)
  have t: "{x,y}={y,x}" by(auto)
  have f: "~ x < y in xs  y < x in Lxy xs {x,y}"
    unfolding t
    apply(rule aha)
      using xyset apply(simp)
      using xy apply(simp)
      using xy xyset by(simp add: not_before_in)
  have b: "~ x < y in xs  ~ x < y in Lxy xs {x,y}"
  proof -
    assume "~ x < y in xs"
    then have "y < x in Lxy xs {x,y}" using f by auto
    then have "~ x < y in Lxy xs {x,y}" using xy by(simp add: not_before_in)
    then show ?thesis .
  qed
  from a b
  show ?thesis by metis
qed


subsection "List Update as Online/Offline Algorithm"

type_synonym 'a state = "'a list"
type_synonym answer = "nat * nat list"

definition step :: "'a state  'a  answer  'a state" where
"step s r a =
  (let (k,sws) = a in mtf2 k r (swaps sws s))"

definition t :: "'a state  'a  answer  nat" where
"t s r a = (let (mf,sws) = a in index (swaps sws s) r + 1 + size sws)"

definition static where "static s rs = (set rs  set s)"

interpretation On_Off step t static .

type_synonym 'a alg_off = "'a state  'a list  answer list"
type_synonym ('a,'is) alg_on = "('a state,'is,'a,answer) alg_on"

lemma T_ge_len: "length as = length rs  T s rs as  length rs"
by(induction arbitrary: s rule: list_induct2)
  (auto simp: t_def trans_le_add2)

lemma T_off_neq0: "(rs s0. size(alg s0 rs) = length rs) 
  rs  []  T_off alg s0 rs  0"
apply(erule_tac x=rs in meta_allE)
apply(erule_tac x=s0 in meta_allE)
apply (auto simp: neq_Nil_conv length_Suc_conv t_def)
done

lemma length_step[simp]: "length (step s r as) = length s"
by(simp add: step_def split_def)

lemma step_Nil_iff[simp]: "step xs r act = []  xs = []"
by(auto simp add: step_def mtf2_def split: prod.splits)

lemma set_step2: "set(step s r (mf,sws)) = set s"
by(auto simp add: step_def)

lemma set_step: "set(step s r act) = set s"
by(cases act)(simp add: set_step2)

lemma distinct_step: "distinct(step s r as) = distinct s"
by (auto simp: step_def split_def)


subsection "Online Algorithm Move-to-Front is 2-Competitive"

definition MTF :: "('a,unit) alg_on" where
"MTF = (λ_. (), λs r. ((size (fst s) - 1,[]), ()))"

text‹It was first proved by Sleator and Tarjan~\cite{SleatorT-CACM85} that
the Move-to-Front algorithm is 2-competitive.›

(* The core idea with upper bounds: *)
lemma potential:
fixes t :: "nat  'a::linordered_ab_group_add" and p :: "nat  'a"
assumes p0: "p 0 = 0" and ppos: "n. p n  0"
and ub: "n. t n + p(n+1) - p n  u n"
shows "(i<n. t i)  (i<n. u i)"
proof-
  let ?a = "λn. t n + p(n+1) - p n"
  have 1: "(i<n. t i) = (i<n. ?a i) - p(n)"
    by(induction n) (simp_all add: p0)
  thus ?thesis
    by (metis (erased, lifting) add.commute diff_add_cancel le_add_same_cancel2 order.trans ppos sum_mono ub)
qed

lemma potential2:
fixes t :: "nat  'a::linordered_ab_group_add" and p :: "nat  'a"
assumes p0: "p 0 = 0" and ppos: "n. p n  0"
and ub: "m. m<n  t m + p(m+1) - p m  u m"
shows "(i<n. t i)  (i<n. u i)"
proof-
  let ?a = "λn. t n + p(n+1) - p n"
  have "(i<n. t i) = (i<n. ?a i) - p(n)" by(induction n) (simp_all add: p0)
  also have      "  (i<n. ?a i)" using ppos by auto
  also have      "  (i<n. u i)" apply(rule sum_mono) apply(rule ub) by auto
  finally show ?thesis .
qed


abbreviation "before x xs  {y. y < x in xs}"
abbreviation "after x xs  {y. x < y in xs}"

lemma finite_before[simp]: "finite (before x xs)"
apply(rule finite_subset[where B = "set xs"])
apply (auto dest: before_in_setD1)
done

lemma finite_after[simp]: "finite (after x xs)"
apply(rule finite_subset[where B = "set xs"])
apply (auto dest: before_in_setD2)
done

lemma before_conv_take:
  "x : set xs  before x xs = set(take (index xs x) xs)"
by (auto simp add: before_in_def set_take_if_index index_le_size) (metis index_take leI)

lemma card_before: "distinct xs  x : set xs  card (before x xs) = index xs x"
using  index_le_size[of xs x]
by(simp add: before_conv_take distinct_card[OF distinct_take] min_def)

lemma before_Un: "set xs = set ys  x : set xs 
  before x ys = before x xs  before x ys Un after x xs  before x ys"
by(auto)(metis before_in_setD1 not_before_in)

lemma phi_diff_aux:
  "card (Inv xs ys 
             {(y, x) |y. y < x in xs  y < x in ys} -
             {(x, y) |y. x < y in xs  y < x in ys}) =
   card(Inv xs ys) + card(before x xs  before x ys)
   - int(card(after x xs  before x ys))"
  (is "card(?I  ?B - ?A) = card ?I + card ?b - int(card ?a)")
proof-
  have 1: "?I  ?B = {}" by(auto simp: Inv_def) (metis no_before_inI)
  have 2: "?A  ?I  ?B" by(auto simp: Inv_def)
  have 3: "?A  ?I" by(auto simp: Inv_def)
  have "int(card(?I  ?B - ?A)) = int(card ?I + card ?B) - int(card ?A)"
    using  card_mono[OF _ 3]
    by(simp add: card_Un_disjoint[OF _ _ 1] card_Diff_subset[OF _ 2])
  also have "card ?B = card (fst ` ?B)" by(auto simp: card_image inj_on_def)
  also have "fst ` ?B = ?b" by force
  also have "card ?A = card (snd ` ?A)" by(auto simp: card_image inj_on_def)
  also have "snd ` ?A = ?a" by force
  finally show ?thesis .
qed

lemma not_before_Cons[simp]: "¬ x < y in y # xs"
by (simp add: before_in_def)

lemma before_Cons[simp]:
  "y  set xs  y  x  before y (x#xs) = insert x (before y xs)"
by(auto simp: before_in_def)

lemma card_before_le_index: "card (before x xs)  index xs x"
apply(cases "x  set xs")
 prefer 2 apply (simp add: before_in_def)
apply(induction xs)
 apply (simp add: before_in_def)
apply (auto simp: card_insert_if)
done

lemma config_config_length: "length (fst (config A init qs)) = length init"
apply (induct rule: config_induct) by (simp_all)

lemma config_config_distinct: 
  shows " distinct (fst (config A init qs)) = distinct init" 
apply (induct rule: config_induct) by (simp_all add: distinct_step)

lemma config_config_set: 
  shows "set (fst (config A init qs)) = set init"
apply(induct rule: config_induct) by(simp_all add: set_step)

lemma config_config:
  "set (fst (config A init qs)) = set init
         distinct (fst (config A init qs)) = distinct init
         length (fst (config A init qs)) = length init"
using config_config_distinct config_config_set config_config_length by metis

lemma config_dist_perm:
  "distinct init  dist_perm (fst (config A init qs)) init"
using config_config_distinct config_config_set by metis
 


lemma config_rand_length: "xset_pmf (config_rand  A init qs). length (fst x) = length init"
apply (induct rule: config_rand_induct) by (simp_all)

lemma config_rand_distinct: 
  shows "x  (config_rand  A init qs). distinct (fst x) = distinct init" 
apply (induct rule: config_rand_induct) by (simp_all add: distinct_step)

lemma config_rand_set: 
  shows " x  (config_rand   A init qs). set (fst x) = set init"
apply(induct rule: config_rand_induct) by(simp_all add: set_step)

lemma config_rand:
  "x  (config_rand   A  init qs). set (fst x) = set init
         distinct (fst x) = distinct init  length (fst x) = length init"
using config_rand_distinct config_rand_set config_rand_length by metis

lemma config_rand_dist_perm:
  "distinct init  x  (config_rand A init qs). dist_perm (fst x) init"
using config_rand_distinct config_rand_set  by metis




(*fixme start from Inv*)

lemma amor_mtf_ub: assumes "x : set ys" "set xs = set ys"
shows "int(card(before x xs Int before x ys)) - card(after x xs Int before x ys)
   2 * int(index xs x) - card (before x ys)" (is "?m - ?n  2 * ?j - ?k")
proof-
  have xxs: "x  set xs" using assms(1,2) by simp
  let ?bxxs = "before x xs" let ?bxys = "before x ys" let ?axxs = "after x xs"
  have 0: "?bxxs  ?axxs = {}" by (auto simp: before_in_def)
  hence 1: "(?bxxs  ?bxys)  (?axxs  ?bxys) = {}" by blast
  have "(?bxxs  ?bxys)  (?axxs  ?bxys) = ?bxys"
    using assms(2) before_Un xxs by fastforce
  hence "?m + ?n = ?k"
    using card_Un_disjoint[OF _ _ 1] by simp
  hence "?m - ?n = 2 * ?m - ?k" by arith
  also have "?m  ?j"
    using card_before_le_index[of x xs] card_mono[of ?bxxs, OF _ Int_lower1]
    by(auto intro: order_trans)
  finally show ?thesis by auto
qed

locale MTF_Off =
fixes as :: "answer list"
fixes rs :: "'a list"
fixes s0 :: "'a list"
assumes dist_s0[simp]: "distinct s0"
assumes len_as: "length as = length rs"
begin

definition mtf_A :: "nat list" where
"mtf_A = map fst as"

definition sw_A :: "nat list list" where
"sw_A = map snd as"

fun s_A :: "nat  'a list" where
"s_A 0 = s0" |
"s_A(Suc n) = step (s_A n) (rs!n) (mtf_A!n, sw_A!n)"

lemma length_s_A[simp]: "length(s_A n) = length s0"
by (induction n) simp_all

lemma dist_s_A[simp]: "distinct(s_A n)" 
by(induction n) (simp_all add: step_def)

lemma set_s_A[simp]: "set(s_A n) = set s0"
by(induction n) (simp_all add: step_def)


fun s_mtf :: "nat  'a list" where
"s_mtf 0 = s0" |
"s_mtf (Suc n) = mtf (rs!n) (s_mtf n)"

definition t_mtf :: "nat  int" where
"t_mtf n = index (s_mtf n) (rs!n) + 1"

definition T_mtf :: "nat  int" where
"T_mtf n = (i<n. t_mtf i)"

definition c_A :: "nat  int" where
"c_A n = index (swaps (sw_A!n) (s_A n)) (rs!n) + 1"

definition f_A :: "nat  int" where
"f_A n = min (mtf_A!n) (index (swaps (sw_A!n) (s_A n)) (rs!n))"

definition p_A :: "nat  int" where
"p_A n = size(sw_A!n)"

definition t_A :: "nat  int" where
"t_A n = c_A n + p_A n"

definition T_A :: "nat  int" where
"T_A n = (i<n. t_A i)"

lemma length_s_mtf[simp]: "length(s_mtf n) = length s0"
by (induction n) simp_all

lemma dist_s_mtf[simp]: "distinct(s_mtf n)"
apply(induction n)
 apply (simp)
apply (auto simp: mtf_def index_take set_drop_if_index)
apply (metis set_drop_if_index index_take less_Suc_eq_le linear)
done

lemma set_s_mtf[simp]: "set (s_mtf n) = set s0"
by (induction n) (simp_all)

lemma dperm_inv: "dist_perm (s_A n) (s_mtf n)"
by (metis dist_s_mtf dist_s_A set_s_mtf set_s_A)

definition Phi :: "nat  int" ("Φ") where
"Phi n = card(Inv (s_A n) (s_mtf n))"

lemma phi0: "Phi 0 = 0"
by(simp add: Phi_def)

lemma phi_pos: "Phi n  0"
by(simp add: Phi_def)

lemma mtf_ub: "t_mtf n + Phi (n+1) - Phi n  2 * c_A n - 1 + p_A n - f_A n"
proof -
  let ?xs = "s_A n" let ?ys = "s_mtf n" let ?x = "rs!n"
  let ?xs' = "swaps (sw_A!n) ?xs" let ?ys' = "mtf ?x ?ys"
  show ?thesis
  proof cases
  assume xin: "?x  set ?ys"
  let ?bb = "before ?x ?xs  before ?x ?ys"
  let ?ab = "after ?x ?xs  before ?x ?ys"
  have phi_mtf:
    "card(Inv ?xs' ?ys') - int(card (Inv ?xs' ?ys))
    2 * int(index ?xs' ?x) - int(card (before ?x ?ys))"
      using xin by(simp add: Inv_mtf phi_diff_aux amor_mtf_ub)
  have phi_sw: "card(Inv ?xs' ?ys)  Phi n + length(sw_A!n)"
  proof -
    have "int(card (Inv ?xs' ?ys))  card(Inv ?xs' ?xs) + int(card(Inv ?xs ?ys))"
      using card_Inv_tri_ineq[of ?xs' ?xs ?ys] xin by (simp)
    also have "card(Inv ?xs' ?xs) = card(Inv ?xs ?xs')"
      by (rule card_Inv_sym)
    also have "card(Inv ?xs ?xs')  size(sw_A!n)"
      by (metis card_Inv_swaps_le dist_s_A)
    finally show ?thesis by(fastforce simp: Phi_def)
  qed
  have phi_free: "card(Inv ?xs' ?ys') - Phi (Suc n) = f_A n" using xin
    by(simp add: Phi_def mtf2_def step_def card_Inv_mtf2 index_less_size_conv f_A_def)
  show ?thesis using xin phi_sw phi_mtf phi_free card_before[of "s_mtf n"]
    by(simp add: t_mtf_def c_A_def p_A_def)
  next
    assume notin: "?x  set ?ys"
    have "int (card (Inv ?xs' ?ys)) - card (Inv ?xs ?ys)  card(Inv ?xs ?xs')"
      using card_Inv_tri_ineq[OF _ dperm_inv, of ?xs' n]
            swaps_inv[of "sw_A!n" "s_A n"]
      by(simp add: card_Inv_sym)
    also have "  size(sw_A!n)"
      by(simp add: card_Inv_swaps_le dperm_inv)
    finally show ?thesis using notin
      by(simp add: t_mtf_def step_def c_A_def p_A_def f_A_def Phi_def mtf2_def)
  qed
qed

theorem Sleator_Tarjan: "T_mtf n  (i<n. 2*c_A i + p_A i - f_A i) - n"
proof-
  have "(i<n. t_mtf i)  (i<n. 2*c_A i - 1 + p_A i - f_A i)"
    by(rule potential[where p=Phi,OF phi0 phi_pos mtf_ub])
  also have " = (i<n. (2*c_A i + p_A i - f_A i) - 1)"
    by (simp add: algebra_simps)
  also have " = (i<n. 2*c_A i + p_A i - f_A i) - n"
    by(simp add: sumr_diff_mult_const2[symmetric])
  finally show ?thesis by(simp add: T_mtf_def)
qed

corollary Sleator_Tarjan': "T_mtf n  2*T_A n - n"
proof -
  have "T_mtf n  (i<n. 2*c_A i + p_A i - f_A i) - n" by (fact Sleator_Tarjan)
  also have "(i<n. 2*c_A i + p_A i - f_A i)  (i<n. 2*(c_A i + p_A i))"
    by(intro sum_mono) (simp add: p_A_def f_A_def)
  also have "  2* T_A n" by (simp add: sum_distrib_left T_A_def t_A_def)
  finally show "T_mtf n  2* T_A n - n" by auto
qed

lemma T_A_nneg: "0  T_A n"
by(auto simp add: sum_nonneg T_A_def t_A_def c_A_def p_A_def)

lemma T_mtf_ub: "i<n. rs!i  set s0  T_mtf n  n * size s0"
proof(induction n)
  case 0 show ?case by(simp add: T_mtf_def)
next
  case (Suc n)  thus ?case
    using index_less_size_conv[of "s_mtf n" "rs!n"]
      by(simp add: T_mtf_def t_mtf_def less_Suc_eq del: index_less)
qed

corollary T_mtf_competitive: assumes "s0  []" and "i<n. rs!i  set s0"
shows "T_mtf n  (2 - 1/(size s0)) * T_A n"
proof cases
  assume 0: "real_of_int(T_A n)  n * (size s0)"
  have "T_mtf n  2 * T_A n - n"
  proof -
    have "T_mtf n  (i<n. 2*c_A i + p_A i - f_A i) - n" by(rule Sleator_Tarjan)
    also have "(i<n. 2*c_A i + p_A i - f_A i)  (i<n. 2*(c_A i + p_A i))"
      by(intro sum_mono) (simp add: p_A_def f_A_def)
    also have "  2 * T_A n" by (simp add: sum_distrib_left T_A_def t_A_def)
    finally show ?thesis by simp
  qed
  hence "real_of_int(T_mtf n)  2 * of_int(T_A n) - n" by simp
  also have " = 2 * of_int(T_A n) - (n * size s0) / size s0"
    using assms(1) by simp
  also have "  2 * real_of_int(T_A n) - T_A n / size s0"
    by(rule diff_left_mono[OF divide_right_mono[OF 0]]) simp
  also have " = (2 - 1 / size s0) * T_A n" by algebra
  finally show ?thesis .
next
  assume 0: "¬ real_of_int(T_A n)  n * (size s0)"
  have "2 - 1 / size s0  1" using assms(1)
    by (auto simp add: field_simps neq_Nil_conv)
  have "real_of_int (T_mtf n)  n * size s0" using T_mtf_ub[OF assms(2)] by linarith
  also have " < of_int(T_A n)" using 0 by simp
  also have "  (2 - 1 / size s0) * T_A n" using assms(1) T_A_nneg[of n]
    by(auto simp add: mult_le_cancel_right1 field_simps neq_Nil_conv)
  finally show ?thesis by linarith
qed

lemma t_A_t: "n < length rs  t_A n = int (t (s_A n) (rs ! n) (as ! n))"
by(simp add: t_A_def t_def c_A_def p_A_def sw_A_def len_as split: prod.split)

lemma T_A_eq_lem: "(i=0..<length rs. t_A i) =
  T (s_A 0) (drop 0 rs) (drop 0 as)"
proof(induction rule: zero_induct[of _ "size rs"])
  case 1 thus ?case by (simp add: len_as)
next
  case (2 n)
  show ?case
  proof cases
    assume "n < length rs"
    thus ?case using 2
    by(simp add: Cons_nth_drop_Suc[symmetric,where i=n] len_as sum.atLeast_Suc_lessThan
      t_A_t mtf_A_def sw_A_def)
  next
    assume "¬ n < length rs" thus ?case by (simp add: len_as)
  qed
qed

lemma T_A_eq: "T_A (length rs) = T s0 rs as"
using T_A_eq_lem by(simp add: T_A_def atLeast0LessThan)

lemma nth_off_MTF: "n < length rs  off2 MTF s rs ! n = (size(fst s) - 1,[])"
by(induction rs arbitrary: s n)(auto simp add: MTF_def nth_Cons' Step_def)

lemma t_mtf_MTF: "n < length rs 
  t_mtf n = int (t (s_mtf n) (rs ! n) (off MTF s rs ! n))"
by(simp add: t_mtf_def t_def nth_off_MTF split: prod.split)

lemma mtf_MTF: "n < length rs  length s = length s0  mtf (rs ! n) s =
       step s (rs ! n) (off MTF s0 rs ! n)"
by(auto simp add: nth_off_MTF step_def mtf_eq_mtf2)

lemma T_mtf_eq_lem: "(i=0..<length rs. t_mtf i) =
  T (s_mtf 0) (drop 0 rs) (drop 0 (off MTF s0 rs))"
proof(induction rule: zero_induct[of _ "size rs"])
  case 1 thus ?case by (simp add: len_as)
next
  case (2 n)
  show ?case
  proof cases
    assume "n < length rs"
    thus ?case using 2
      by(simp add: Cons_nth_drop_Suc[symmetric,where i=n] len_as sum.atLeast_Suc_lessThan
        t_mtf_MTF[where s=s0] mtf_A_def sw_A_def mtf_MTF)
  next
    assume "¬ n < length rs" thus ?case by (simp add: len_as)
  qed
qed

lemma T_mtf_eq: "T_mtf (length rs) = T_on MTF s0 rs"
using T_mtf_eq_lem by(simp add: T_mtf_def atLeast0LessThan)

corollary MTF_competitive2: "s0  []  i<length rs. rs!i  set s0 
  T_on MTF s0 rs  (2 - 1/(size s0)) * T s0 rs as"
by (metis T_mtf_competitive T_A_eq T_mtf_eq of_int_of_nat_eq)

corollary MTF_competitive': "T_on MTF s0 rs  2 * T s0 rs as"
using Sleator_Tarjan'[of "length rs"] T_A_eq T_mtf_eq
by auto

end

theorem compet_MTF: assumes "s0  []" "distinct s0" "set rs  set s0"
shows "T_on MTF s0 rs  (2 - 1/(size s0)) * T_opt s0 rs"
proof-
  from assms(3) have 1: "i < length rs. rs!i  set s0" by auto
  { fix as :: "answer list" assume len: "length as = length rs"
    interpret MTF_Off as rs s0 proof qed (auto simp: assms(2) len)
    from MTF_competitive2[OF assms(1) 1] assms(1)
    have "T_on MTF s0 rs / (2 - 1 / (length s0))  of_int(T s0 rs as)"
      by(simp add: field_simps length_greater_0_conv[symmetric]
        del: length_greater_0_conv) }
  hence "T_on MTF s0 rs / (2 - 1/(size s0))  T_opt s0 rs"
    apply(simp add: T_opt_def Inf_nat_def)
    apply(rule LeastI2_wellorder)
    using length_replicate[of "length rs" undefined] apply fastforce
    apply auto
    done
  thus ?thesis using assms by(simp add: field_simps
    length_greater_0_conv[symmetric] del: length_greater_0_conv)
qed

theorem compet_MTF': assumes "distinct s0"
shows "T_on MTF s0 rs  (2::real) * T_opt s0 rs"
proof- 
  { fix as :: "answer list" assume len: "length as = length rs"
    interpret MTF_Off as rs s0 proof qed (auto simp: assms(1) len)
    from MTF_competitive'
    have "T_on MTF s0 rs / 2  of_int(T s0 rs as)"
      by(simp add: field_simps length_greater_0_conv[symmetric]
        del: length_greater_0_conv) }
  hence "T_on MTF s0 rs / 2  T_opt s0 rs"
    apply(simp add: T_opt_def Inf_nat_def)
    apply(rule LeastI2_wellorder)
    using length_replicate[of "length rs" undefined] apply fastforce
    apply auto
    done
  thus ?thesis using assms by(simp add: field_simps
    length_greater_0_conv[symmetric] del: length_greater_0_conv)
qed
 
theorem MTF_is_2_competitive: "compet MTF 2 {s . distinct s}"
unfolding compet_def using compet_MTF' by fastforce 


subsection "Lower Bound for Competitiveness"

text‹This result is independent of MTF
but is based on the list update problem defined in this theory.›

lemma rat_fun_lem:
   fixes l c :: real
   assumes [simp]: "F  bot"
   assumes "0 < l"
   assumes ev: 
     "eventually (λn. l  f n / g n) F"
     "eventually (λn. (f n + c) / (g n + d)  u) F"
   and
     g: "LIM n F. g n :> at_top"
   shows "l  u"
proof (rule dense_le_bounded[OF 0 < l])
   fix x assume x: "0 < x" "x < l"

   define m where "m = (x - l) / 2"
   define k where "k = l / (x - m)"
   have "x = l / k + m" "1 < k" "m < 0"
     unfolding k_def m_def using x by (auto simp: divide_simps)
   
   from 1 < k have "LIM n F. (k - 1) * g n :> at_top"
     by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const _ g]) (simp add: field_simps)
   then have "eventually (λn. d  (k - 1) * g n) F"
     by (simp add: filterlim_at_top)
   moreover have "eventually (λn. 1  g n) F" "eventually (λn. 1 - d  g n) F" "eventually (λn. c / m - d  g n) F"
     using g by (auto simp add: filterlim_at_top)
   ultimately have "eventually (λn. x  u) F"
     using ev
   proof eventually_elim
     fix n assume d: "d  (k - 1) * g n" "1  g n" "1 - d  g n" "c / m - d  g n"
       and l: "l  f n / g n" and u: "(f n + c) / (g n + d)  u"
     from d have "g n + d  k * g n"
       by (simp add: field_simps)
     from d have g: "0 < g n" "0 < g n + d"
       by (auto simp: field_simps)
     with 0 < l l have "0 < f n"
       by (auto simp: field_simps intro: mult_pos_pos less_le_trans)

     note x = l / k + m
     also have "l / k  f n / (k * g n)"
       using l 1 < k by (simp add: field_simps)
     also have "  f n / (g n + d)"
       using d 1 < k 0 < f n by (intro divide_left_mono mult_pos_pos) (auto simp: field_simps)
     also have "m  c / (g n + d)"
       using c / m - d  g n 0 < g n 0 < g n + d m < 0 by (simp add: field_simps)
     also have "f n / (g n + d) + c / (g n + d) = (f n + c) / (g n + d)"
       using 0 < g n + d by (auto simp: add_divide_distrib)
     also note u
     finally show "x  u" by simp
   qed
   then show "x  u" by auto
qed


lemma compet_lb0:
fixes a Aon Aoff cruel 
defines "f s0 rs == real(T_on Aon s0 rs)"
defines "g s0 rs == real(T_off Aoff s0 rs)"
assumes "rs s0. size(Aoff s0 rs) = length rs" and "n. cruel n  []"
assumes "compet Aon c S0" and "c0" and "s0  S0"
 and l: "eventually (λn. f s0 (cruel n) / (g s0 (cruel n) + a)  l) sequentially"
 and g: "LIM n sequentially. g s0 (cruel n) :> at_top"
 and "l > 0" and "n. static s0 (cruel n)"
shows "l  c"
proof-
  let ?h = "λb s0 rs. (f s0 rs - b) / g s0 rs"
  have g': "LIM n sequentially. g s0 (cruel n) + a :> at_top"
    using filterlim_tendsto_add_at_top[OF tendsto_const g]
    by (simp add: ac_simps)
  from competE[OF assms(5) c0 _ s0  S0] assms(3) obtain b where
    "rs. static s0 rs  rs  []  ?h b s0 rs  c "
    by (fastforce simp del: neq0_conv simp: neq0_conv[symmetric]
        field_simps f_def g_def T_off_neq0[of Aoff, OF assms(3)])
  hence "n. (?h b s0 o cruel) n  c" using assms(4,11) by simp
  with rat_fun_lem[OF sequentially_bot l>0 _ _ g', of "f s0 o cruel" "-b" "- a" c] assms(7) l
  show "l  c" by (auto)
qed

text ‹Sorting›

fun ins_sws where
"ins_sws k x [] = []" |
"ins_sws k x (y#ys) = (if k x  k y then [] else map Suc (ins_sws k x ys) @ [0])"

fun sort_sws where
"sort_sws k [] = []" |
"sort_sws k (x#xs) =
  ins_sws k x (sort_key k xs) @  map Suc (sort_sws k xs)"

lemma length_ins_sws: "length(ins_sws k x xs)  length xs"
by(induction xs) auto

lemma length_sort_sws_le: "length(sort_sws k xs)  length xs ^ 2"
proof(induction xs)
  case (Cons x xs) thus ?case
    using length_ins_sws[of k x "sort_key k xs"] by (simp add: numeral_eq_Suc)
qed simp

lemma swaps_ins_sws:
  "swaps (ins_sws k x xs) (x#xs) = insort_key k x xs"
by(induction xs)(auto simp: swap_def[of 0])

lemma swaps_sort_sws[simp]:
  "swaps (sort_sws k xs) xs = sort_key k xs"
by(induction xs)(auto simp: swaps_ins_sws)

text‹The cruel adversary:›

fun cruel :: "('a,'is) alg_on  'a state * 'is  nat  'a list" where
"cruel A s 0 = []" |
"cruel A s (Suc n) = last (fst s) # cruel A (Step A s (last (fst s))) n"

definition adv :: "('a,'is) alg_on  ('a::linorder) alg_off" where
"adv A s rs = (if rs=[] then [] else
  let crs = cruel A (Step A (s, fst A s) (last s)) (size rs - 1)
  in (0,sort_sws (λx. size rs - 1 - count_list crs x) s) # replicate (size rs - 1) (0,[]))"

lemma set_cruel: "s  []  set(cruel A (s,is) n)  set s"
apply(induction n arbitrary: s "is")
apply(auto simp: step_def Step_def split: prod.split)
by (metis empty_iff swaps_inv last_in_set list.set(1) rev_subsetD set_mtf2)

lemma static_cruel: "s  []  static s (cruel A (s,is) n)"
by(simp add: set_cruel static_def)

(* Do not convert into structured proof - eta conversion screws it up! *)
lemma T_cruel:
  "s  []  distinct s 
  T s (cruel A (s,is) n) (off2 A (s,is) (cruel A (s,is) n))  n*(length s)"
apply(induction n arbitrary: s "is")
 apply(simp)
apply(erule_tac x = "fst(Step A (s, is) (last s))" in meta_allE)
apply(erule_tac x = "snd(Step A (s, is) (last s))" in meta_allE)
apply(frule_tac sws = "snd(fst(snd A (s,is) (last s)))" in index_swaps_last_size)
apply(simp add: distinct_step t_def split_def Step_def
        length_greater_0_conv[symmetric] del: length_greater_0_conv)
done

lemma length_cruel[simp]: "length (cruel A s n) = n"
by (induction n arbitrary: s) (auto)

lemma t_sort_sws: "t s r (mf, sort_sws k s)  size s ^ 2 + size s + 1"
using length_sort_sws_le[of k s] index_le_size[of "sort_key k s" r]
by (simp add: t_def add_mono index_le_size algebra_simps)

lemma T_noop:
  "n = length rs  T s rs (replicate n (0, [])) = (rrs. index s r + 1)"
by(induction rs arbitrary: s n)(auto simp: t_def step_def)


lemma sorted_asc: "ji  i<size ss  x  set ss. y  set ss. k(x)  k(y)  f y  f x
   sorted (map k ss)  f (ss ! i)  f (ss ! j)"
by (auto simp: sorted_iff_nth_mono)


lemma sorted_weighted_gauss_Ico_div2:
  fixes f :: "nat  nat"
  assumes "i j. i  j  j < n  f i  f j"
  shows "(i=0..<n. (i + 1) * f i)  (n + 1) * sum f {0..<n} div 2"
proof (cases n)
  case 0
  then show ?thesis
    by simp
next
  case (Suc n)
  with assms have "Suc n * (i=0..<Suc n. Suc i * f i)  (i=0..<Suc n. Suc i) * sum f {0..<Suc n}"
    by (intro Chebyshev_sum_upper_nat [of "Suc n" Suc f]) auto
  then have "Suc n * (2 * (i=0..n. Suc i * f i))  2 * (i=0..n. Suc i) * sum f {0..n}"
    by (simp add: atLeastLessThanSuc_atLeastAtMost)
  also have "2 * (i=0..n. Suc i) = Suc n * (n + 2)"
    using arith_series_nat [of 1 1 n] by simp
  finally have "2 * (i=0..n. Suc i * f i)  (n + 2) * sum f {0..n}"
    by (simp only: ac_simps Suc_mult_le_cancel1)
  with Suc show ?thesis
    by (simp only: atLeastLessThanSuc_atLeastAtMost) simp
qed

lemma T_adv: assumes "l  0"
shows "T_off (adv A) [0..<l] (cruel A ([0..<l],fst A [0..<l]) (Suc n))
   l2 + l + 1 + (l + 1) * n div 2"  (is "?l  ?r")
proof-
  let ?s = "[0..<l]"
  let ?r = "last ?s"
  let ?S' = "Step A (?s,fst A ?s) ?r"
  let ?s' = "fst ?S'"
  let ?cr = "cruel A ?S' n"
  let ?c = "count_list ?cr"
  let ?k = "λx. n - ?c x"
  let ?sort = "sort_key ?k ?s"
  have 1: "set ?s' = {0..<l}"
    by(simp add: set_step Step_def split: prod.split)
  have 3: "x. x < l  ?c x  n"
    by(simp) (metis count_le_length length_cruel)
  have "?l = t ?s (last ?s) (0, sort_sws ?k ?s) + (xset ?s'. ?c x * (index ?sort x + 1))"
    using assms
    apply(simp add:  adv_def T_noop sum_list_map_eq_sum_count2[OF set_cruel] Step_def
      split: prod.split)
    apply(subst (3) step_def)
    apply(simp)
    done
  also have "(xset ?s'. ?c x * (index ?sort x + 1)) = (x{0..<l}. ?c x * (index ?sort x + 1))"
    by (simp add: 1)
  also have " = (x{0..<l}. ?c (?sort ! x) * (index ?sort (?sort ! x) + 1))"
    by(rule sum.reindex_bij_betw[where ?h = "nth ?sort", symmetric])
      (simp add: bij_betw_imageI inj_on_nth nth_image)
  also have " = (x{0..<l}. ?c (?sort ! x) * (x+1))"
    by(simp add: index_nth_id)
  also have "  (x{0..<l}. (x+1) * ?c (?sort ! x))"
    by (simp add: algebra_simps)
  also(ord_eq_le_subst) have "  (l+1) * (x{0..<l}. ?c (?sort ! x)) div 2"
    apply(rule sorted_weighted_gauss_Ico_div2)
    apply(erule sorted_asc[where k = "λx. n - count_list (cruel A ?S' n) x"])
    apply(auto simp add: index_nth_id dest!: 3)
    using assms [[linarith_split_limit = 20]] by simp
  also have "(x{0..<l}. ?c (?sort ! x)) = (x{0..<l}. ?c (?sort ! (index ?sort x)))"
    by(rule sum.reindex_bij_betw[where ?h = "index ?sort", symmetric])
      (simp add: bij_betw_imageI inj_on_index2 index_image)
  also have " = (x{0..<l}. ?c x)" by(simp)
  also have " = length ?cr"
    using set_cruel[of ?s' A _ n] assms 1
    by(auto simp add: sum_count_set Step_def split: prod.split)
  also have " = n" by simp
  also have "t ?s (last ?s) (0, sort_sws ?k ?s)  (length ?s)^2 + length ?s + 1"
    by(rule t_sort_sws)
  also have " = l^2 + l + 1" by simp
  finally show "?l  l2 + l + 1 + (l + 1) * n div 2" by auto
qed

text ‹The main theorem:›

theorem compet_lb2:
assumes "compet A c {xs::nat list. size xs = l}" and "l  0" and "c  0"
shows "c  2*l/(l+1)"
proof (rule compet_lb0[OF _ _ assms(1) c0])
  let ?S0 = "{xs::nat list. size xs = l}"
  let ?s0 = "[0..<l]"
  let ?cruel = "cruel A (?s0,fst A ?s0) o Suc"
  let ?on = "λn. T_on A ?s0 (?cruel n)"
  let ?off = "λn. T_off (adv A) ?s0 (?cruel n)"
  show "s0 rs. length (adv A s0 rs) = length rs" by(simp add: adv_def)
  show "n. ?cruel n  []" by auto
  show "?s0  ?S0" by simp
  { fix Z::real and n::nat assume "n  nat(ceiling Z)"
    have "?off n  length(?cruel n)" by(rule T_ge_len) (simp add: adv_def)
    hence "?off n > n" by simp
    hence "Z  ?off n" using n  nat(ceiling Z) by linarith }
  thus "LIM n sequentially. real (?off n) :> at_top"
    by(auto simp only: filterlim_at_top eventually_sequentially)
  let ?a = "- (l^2 + l + 1)"
  { fix n assume "n  l^2 + l + 1"
    have "2*l/(l+1) = 2*l*(n+1) / ((l+1)*(n+1))"
      by (simp del: One_nat_def)
    also have " = 2*real(l*(n+1)) / ((l+1)*(n+1))" by simp
    also have "l * (n+1)  ?on n"
      using T_cruel[of ?s0 "Suc n"] l  0
      by (simp add: ac_simps)
    also have "2*real(?on n) / ((l+1)*(n+1))  2*real(?on n)/(2*(?off n + ?a))"
    proof -
      have 0: "2*real(?on n)  0" by simp
      have 1: "0 < real ((l + 1) * (n + 1))" by (simp del: of_nat_Suc)
      have "?off n  length(?cruel n)"
        by(rule T_ge_len) (simp add: adv_def)
      hence "?off n > n" by simp
      hence "?off n + ?a > 0" using n  l^2 + l + 1 by linarith
      hence 2: "real_of_int(2*(?off n + ?a)) > 0"
        by(simp only: of_int_0_less_iff zero_less_mult_iff zero_less_numeral simp_thms)
      have "?off n + ?a  (l+1)*(n) div 2"
        using T_adv[OF l0, of A n]
        by (simp only: o_apply of_nat_add of_nat_le_iff)
      also have "  (l+1)*(n+1) div 2" by (simp)
      finally have "2*(?off n + ?a)  (l+1)*(n+1)"
        by (simp add: zdiv_int)
      hence "of_int(2*(?off n + ?a))  real((l+1)*(n+1))" by (simp only: of_int_le_iff)
      from divide_left_mono[OF this 0 mult_pos_pos[OF 1 2]] show ?thesis .
    qed
    also have " = ?on n / (?off n + ?a)"
      by (simp del: distrib_left_numeral One_nat_def cruel.simps)
    finally have "2*l/(l+1)  ?on n / (real (?off n) + ?a)"
      by (auto simp: divide_right_mono)
  }
  thus "eventually (λn. (2 * l) / (l + 1)  ?on n / (real(?off n) + ?a)) sequentially"
    by(auto simp add: filterlim_at_top eventually_sequentially)
  show "0 < 2*l / (l+1)" using l  0 by(simp)
  show "n. static ?s0 (?cruel n)" using l  0 by(simp add: static_cruel del: cruel.simps)
qed


end

Theory Bit_Strings

(*  Title:       Lemmas about lists of bools
    Author:      Max Haslbeck
*)
theory Bit_Strings
imports Complex_Main
begin

section "Lemmas about BitStrings and sets theirof"
 
subsection "the set of bitstring of length m is finite"

lemma bitstrings_finite: "finite {xs::bool list. length xs = m}"
using finite_lists_length_eq[where A="UNIV"] by force

subsection "how to calculate the cardinality of the set of bitstrings with certain bits already set"

lemma fbool: "finite {xs. (iX. xs ! i)  (iY. ¬ xs ! i)  length xs = m  f (xs!e)}"
  by(rule finite_subset[where B="{xs. length xs = m}"])
     (auto simp: bitstrings_finite)

fun witness :: "nat set  nat  bool list" where
 "witness X 0 = []"
|"witness X (Suc n) = (witness X n) @ [n  X]"

lemma witness_length: "length (witness X n) = n"
apply(induct n) by auto

lemma iswitness: "r<n  ((witness X n)!r) = (rX)"
proof (induct n)
  case (Suc n)

  have "witness X (Suc n) ! r = ((witness X n) @ [n  X]) ! r" by simp
  also have " = (if r < length (witness X n) then (witness X n) ! r else [n  X] ! (r - length (witness X n)))" by(rule nth_append)
  also have " = (if r < n then (witness X n) ! r else [n  X] ! (r - n))" by (simp add: witness_length)
  finally have 1: "witness X (Suc n) ! r = (if r < n then (witness X n) ! r else [n  X] ! (r - n))" .
  
  show ?case
  proof (cases "r < n")
    case True
    with 1 have a: "witness X (Suc n) ! r = (witness X n) ! r" by auto
    from Suc True have b: "witness X n ! r = (r  X)" by auto
    from a b show ?thesis by auto
  next
    case False
    with Suc have "r = n" by auto
    with 1 show "witness X (Suc n) ! r = (r  X)" by auto
  qed
qed simp

lemma card1: "finite S  finite X  finite Y  X  Y = {}  S  (X  Y) = {}  SXY={0..<m}  
    card {xs. (iX. xs ! i)  (iY. ¬ xs ! i)   length xs = m} = 2^(m - card X - card Y)"
proof(induct arbitrary: X Y rule: finite_induct)
  case empty
  then have x: "X  {0..<m}" and y: "Y  {0..<m}" and xy: "X Y = {0..<m}" by auto
  then have "card (X  Y) = m" by auto
  with empty(3) have cardXY: "card X + card Y = m" using card_Un_Int[OF empty(1) empty(2)] by auto

  
  from empty have ents: "i<m. (iY) = (iX)" by auto

  have "(∃! w. (iX. w ! i)  (iY. ¬ w ! i)   length w = m)"
  proof (rule ex1I, goal_cases)
    case 1
    show "(iX. (witness X m) ! i)  (iY. ¬ (witness X m) ! i)  length (witness X m) = m"
    proof (safe, goal_cases)
      case (2 i)
      with y have a: "i < m" by auto
      with iswitness have "witness X m ! i = (i  X)" by auto
      with a ents 2 have "~ witness X m ! i" by auto
      with 2(2) show "False" by auto
    next
      case (1 i)
      with x have a: "i < m" by auto
      with iswitness have "witness X m ! i = (i  X)" by auto
      with a ents 1 show "witness X m ! i" by auto
    qed (rule witness_length)
  next
    case (2 w)
    show "w = witness X m"
    proof -
      have "(length w = length (witness X m)  (i<length w. w ! i = (witness X m) ! i))"
       using 2 apply(simp add: witness_length)
       proof 
        fix i 
        assume as: "(iX. w ! i)  (iY. ¬ w ! i)   length w = m"
        have "i < m  (witness X m) ! i = (i  X)" using iswitness by auto
        then show "i < m  w ! i = (witness X m) ! i" using ents as by auto
       qed
      then show ?thesis using list_eq_iff_nth_eq by auto
    qed
  qed
  then obtain w where " {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)   length xs = m}
         = { w }" using Nitpick.Ex1_unfold[where P="(λxs. Ball X ((!) xs)  (iY. ¬ xs ! i)   length xs = m)"]
         by auto

  then have "card {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)   length xs = m} = card { w }" by auto
  also have " = 1" by auto 
  also have " = 2^(m - card X - card Y)" using cardXY by auto
  finally show ?case .
next
  case (insert e S)
  then have eX: "e  X" and eY: "e  Y"  by auto
  from insert(8) have "insert e S  {0..<m}" by auto
  then have ebetween0m: "e{0..<m}" by auto

  have fm: "finite {0..<m}" by auto
  have cardm: "card {0..<m} =   m" by auto
  from insert(8) eX eY ebetween0m have sub: "X  Y  {0..<m}" by auto
  from insert have "card (X  Y) = 0" by auto
  then have cardXY: "card (X  Y) = card X + card Y" using card_Un_Int[OF insert(4) insert(5)] by auto
  
  have "  m > card X + card Y" using psubset_card_mono[OF fm sub] cardm cardXY by(auto)
  then have carde: "1 + (  m - card X - card Y - 1) =   m - card X - card Y" by auto

  have is1: "{xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  xs!e}
          = {xs. Ball (insert e X) ((!) xs)  (iY. ¬ xs ! i)  length xs =   m}" by auto
  have is2: "{xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  ~xs!e}
          = {xs. Ball X ((!) xs)  (i(insert e Y). ¬ xs ! i)  length xs =   m}" by auto
         
  have 2: "{xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  xs!e}
         {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  ~xs!e}
          = {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m}" by auto

  have 3: "{xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  xs!e}
       {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs =   m  ~xs!e} = {}" by auto

  have fX: "finite (insert e X)" 
    and disjeXY: "insert e X  Y = {}" 
    and cutX: "S  (insert e X  Y) = {}"
    and uniX: "S  insert e X  Y = {0..<m}" using insert by auto
  have fY: "finite (insert e Y)"
    and disjXeY: "X  (insert e Y) = {}" 
    and cutY: "S  (X  insert e Y) = {}"
    and uniY: "S   X  insert e Y = {0..<m}" using insert by auto

  have "card {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs = m}
      = card {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs = m  xs!e}
        + card {xs. Ball X ((!) xs)  (iY. ¬ xs ! i)  length xs = m  ~xs!e}"
      apply(subst card_Un_Int)
        apply(rule fbool) apply(rule fbool) using 2 3 by auto
  also
  have " = card {xs. Ball (insert e X) ((!) xs)  (iY. ¬ xs ! i)  length xs =   m}
        + card {xs. Ball X ((!) xs)  (i(insert e Y). ¬ xs ! i)  length xs =   m}" by (simp only: is1 is2)
  
  also
  have " = 2 ^ (  m - card (insert e X) - card Y)
        + 2 ^ (  m - card X - card (insert e Y))" 
          apply(simp only: insert(3)[of "insert e X" Y, OF fX insert(5) disjeXY cutX uniX])
          by(simp only: insert(3)[of "X" "insert e Y", OF insert(4) fY disjXeY cutY uniY])
  also
  have " = 2 ^ (  m - card X - card Y - 1)
        + 2 ^ (  m - card X - card Y - 1)" using insert(4,5) eX eY by auto
  also
  have " = 2 * 2 ^ (  m - card X - card Y - 1)"  by auto
  also have " = 2 ^ (1 + (  m - card X - card Y - 1))" by auto
  also have " = 2 ^ (  m - card X - card Y)" using carde by auto
  finally show ?case .
qed

lemma card2: assumes "finite X" and "finite Y" and "X  Y = {}" and x: "X  Y  {0..<m}"
  shows "card {xs. (iX. xs ! i)  (iY. ¬ xs ! i)  length xs = m} = 2 ^ (m - card X - card Y)"
proof -
  let ?S = "{0..<m}-(X  Y)"
  from x have a: "?S  X  Y = {0..<m}" by auto
  have b: "?S  (X  Y) = {}" by auto  
  show ?thesis apply(rule card1[where ?S="?S"]) by(simp_all add: assms a b)
qed
 

subsection "Average out the second sum for free-absch"
 
lemma Expactation2or1: "finite S  finite Tr  finite Fa  card Tr + card Fa + card S  l 
  S  (Tr  Fa) = {}  Tr  Fa = {}  S  Tr  Fa  {0..<l} 
  (x{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l}. jS. if x ! j then 2 else 1)
      = 3 / 2 * real (card S) * 2 ^ (l - card Tr - card Fa)"
proof (induct arbitrary: Tr Fa rule: finite_induct)
  case (insert e S) 

  from insert(7) have "e  (insert e S)" and eTr: "e  Tr" and eFa: "e  Fa" by auto 
  from insert(9) have  tra: "Tr  {0..<l}" and trb: "Fa  {0..<l}" and  trc: "e < l" by auto 

  have ntrFa: "l > (card Tr + card Fa)" using insert(6) card_insert_if insert(1,2) by auto

  have myhelp2: "1 + (l - card Tr - card Fa -1) = l - card Tr - card Fa" using ntrFa by auto

  have juhuTr: "{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l  xs!e}  
      = {xs. (i(insert e Tr). xs ! i)  (iFa. ¬ xs ! i)  length xs = l}"
       by auto
  have juhuFa: "{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l  ~xs!e}  
      = {xs. (iTr. xs ! i)  (i(insert e Fa). ¬ xs ! i)  length xs = l}"
       by auto

  let ?Tre = "{xs. (i(insert e Tr). xs ! i)  (iFa. ¬ xs ! i)  length xs = l}"

  have "card ?Tre = 2 ^ (l - card (insert e Tr) - card Fa)"
          apply(rule card2) using insert by simp_all
  then have resi: "card ?Tre = 2^(l - card Tr - card Fa - 1)" using insert(4) eTr by auto   
  have yabaTr: "(x?Tre. 2::real) = 2 * 2^(l - card Tr - card Fa - 1)" using resi by (simp add: power_commutes) 


  let ?Fae = "{xs. (iTr. xs ! i)  (i(insert e Fa). ¬ xs ! i)  length xs = l}"

  have "card ?Fae = 2 ^ (l - card Tr - card (insert e Fa))"
          apply(rule card2) using insert by simp_all
  then have resi2: "card ?Fae = 2^(l - card Tr - card Fa - 1)" using insert(5) eFa by auto
  have yabaFa: "(x?Fae. 1::real) = 1 * 2 ^ (l - card Tr - card Fa - 1)" using resi2 by (simp add: power_commutes)
                         
 
  { fix X Y
      have "{xs. (iX. xs ! i)  (iY. ¬ xs ! i)  length xs = l  xs!e}
           {xs. (iX. xs ! i)  (iY. ¬ xs ! i)  length xs = l  ~xs!e} = {}" by auto
  } note 3=this

  (* split it! *)
  have "(x{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l}. j(insert e S). if x ! j then (2::real) else 1)
      = (x{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l  xs!e}. j(insert e S). if x ! j then 2 else 1)
        + (x{xs. (iTr. xs ! i)  (iFa. ¬ xs ! i)  length xs = l  ~xs!e}. j(insert e S). if x ! j then 2 else 1)"
        (is "(x?all. ?f x) = (x?allT. ?f x) + (x?allF. ?f x)")
        proof - 
          have "(x?all. j(insert e S). if x ! j then 2 else 1)
            = (x(?allT  ?allF). j(insert e S). if x ! j then 2 else 1)" apply(rule sum.cong) by(auto)
          also have" = ((x(?allT). j(insert e S). if x ! j then (2::real) else 1) 
                      + (x(?allF). j(insert e S). if x ! j then (2::real) else 1))
                      - (x(?allT  ?allF). j(insert e S). if x ! j then 2 else 1)" 
                   apply (rule sum_Un) apply(rule fbool)+ done
          also have " =  (x(?allT). j(insert e S). if x ! j then 2 else 1)
                        + (x(?allF). j(insert e S). if x ! j then 2 else 1)"
                by(simp add: 3) 
          finally show ?thesis .
        qed 
  also 
  have " = (x?Tre. j(insert e S). if x ! j then 2 else 1)
          + (x?Fae. j(insert e S). if x ! j then 2 else 1)" 
       using juhuTr juhuFa by auto 
  also
  have " =  (x?Tre. (λx. 2) x + (λx. (jS. if x ! j then 2 else 1)) x)
        + (x?Fae. (λx. 1) x + (λx. (jS. if x ! j then 2 else 1)) x)" 
        using insert(1,2) by auto
  also
  have " =  (x?Tre. 2) + (x?Tre. (jS. if x ! j then 2 else 1))
          + ((x?Fae. 1) + (x?Fae. (jS. if x ! j then 2 else 1)))"
          by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib)
  also
  have " =  2 * 2^(l - card Tr - card Fa - 1) + (x?Tre. (jS. if x ! j then 2 else 1))
        + (1 * 2^(l - card Tr - card Fa - 1) + (x?Fae. (jS. if x ! j then 2 else 1)))" 
        by(simp only: yabaTr yabaFa)
  also
  have " =  (2::real) * 2^(l - card Tr - card Fa - 1) + (x?Tre. (jS. if x ! j then 2 else 1))
        + (1::real) * 2^(l - card Tr - card Fa - 1) + (x?Fae. (jS. if x ! j then 2 else 1))" 
        by auto
  also          
  have " =  (3::real) * 2^(l - card Tr - card Fa - 1) +
          (x?Tre. (jS. if x ! j then 2 else 1)) + (x?Fae. (jS. if x ! j then 2 else 1))" 
        by simp
  also
  have " =  3 * 2^(l - card Tr - card Fa - 1) +
          3 / 2 * real (card S) * 2 ^ (l - card (insert e Tr) - card Fa) +
          (x?Fae. (jS. if x ! j then 2 else 1))" 
        apply(subst insert(3)) using insert by simp_all
  also
  have " =  3 * 2^(l - card Tr - card Fa - 1) +
          3 / 2 * real (card S) * 2 ^ (l - card (insert e Tr) - card Fa) +
           3 / 2 * real (card S) * 2 ^ (l - card Tr - card (insert e Fa))"
        apply(subst insert(3)) using insert by simp_all
  also
  have " =  3 * 2^(l - card Tr - card Fa - 1) +
          3 / 2 * real (card S) * 2^ (l - (card Tr + 1) - card Fa) +
           3 / 2 * real (card S) * 2^ (l - card Tr - (card Fa + 1))" using card_insert_if insert(4,5) eTr eFa by auto
  also
  have " =  3  * 2^(l - card Tr - card Fa - 1) +
          3 / 2 * real (card S) * 2^ (l - card Tr - card Fa - 1) +
           3 / 2 * real (card S) * 2^ (l - card Tr - card Fa - 1)" by auto
  also
  have " =  ( 3/2 * 2  +  2 *  3 / 2 * real (card S)) * 2^ (l - card Tr - card Fa - 1)" by algebra
  also
  have " =  (   3 / 2 * (1 + real (card S))) * 2 * 2^ (l - card Tr - card Fa - 1 )" by simp 
  also
  have " =  (   3 / 2 * (1 + real (card S))) * 2^ (Suc (l - card Tr - card Fa -1 ))" by simp 
  also
  have " =  (   3 / 2 * (1 + real (card S))) * 2^ (l - card Tr - card Fa )" using myhelp2 by auto
  also
  have " =  (   3 / 2 * (real (1 + card S))) * 2^ (l - card Tr - card Fa )" by simp 
  also
  have " =  (   3 / 2 * real (card (insert e S))) * 2^ (l - card Tr - card Fa)" using insert(1,2) by auto
  finally show ?case  .
qed simp

end

Theory MTF2_Effects

(*  Title:       Effects of the function mtf2 on index and before_in
    Author:      Max Haslbeck
*)

section "Effect of mtf2"

theory MTF2_Effects
imports Move_to_Front
begin



lemma difind_difelem: 
       "i < length xs  distinct xs  xs ! j = a  j < length xs  i  j 
           ~ a = xs ! i"
apply(rule ccontr) by(metis index_nth_id)


lemma fullchar: assumes  "index xs q < length xs"
  shows 
    "(i < length xs) =
  (index xs q < i  i < length xs
     index xs q = i
     index xs q - n  i  i < index xs q
     i < index xs q - n)"
using assms by auto

lemma mtf2_effect:
    "q  set xs  distinct xs  (index xs q < i  i < length xs ( index (mtf2 n q xs) (xs!i) = index xs (xs!i)  index xs q < index (mtf2 n q xs) (xs!i)  index (mtf2 n q xs) (xs!i) < length xs))
     (index xs q = i  (index (mtf2 n q xs) (xs!i) = index xs q - n  index (mtf2 n q xs) (xs!i) = index xs q - n))
     (index xs q - n  i  i < index xs q  (index (mtf2 n q xs) (xs!i) = Suc (index xs (xs!i))  index xs q - n < index (mtf2 n q xs) (xs!i)  index (mtf2 n q xs) (xs!i)  index xs q))
     (i < index xs q - n  (index (mtf2 n q xs) (xs!i) = index xs (xs!i)  index (mtf2 n q xs) (xs!i) < index xs q - n))"
unfolding mtf2_def
apply (induct n)
proof -
  case (Suc n)
  note indH=Suc(1)[OF Suc(2) Suc(3), simplified Suc(2) if_True] 
  note qinxs=Suc(2)[simp]
  note distxs=Suc(3)[simp]
  show ?case (is ?toshow)
  apply(simp only: qinxs if_True)
  proof (cases "index xs q  Suc n")
    case True 
    note True1=this
from True have onemore: "[index xs q - Suc n..<index xs q] = (index xs q - Suc n) # [index xs q - n..<index xs q]"
              using Suc_diff_Suc upt_rec by auto

        from onemore have yeah: "swaps [index xs q - Suc n..<index xs q] xs
            = swap (index xs q - Suc n) (swaps  [index xs q - n..<index xs q] xs)" by auto

      have sis: "Suc (index xs q - Suc n) = index xs q - n" using True Suc_diff_Suc by auto
      
      have indq: "index xs q < length xs"
        apply(rule index_less) by auto
 
      let ?i' = "index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i)"
      let ?x = "(xs!i)" and  ?xs="(swaps  [index xs q - n..<index xs q] xs)"
              and ?n="(index xs q - Suc n)"
      have "?i'
          =  index (swap (index xs q - Suc n) (swaps  [index xs q - n..<index xs q] xs)) (xs!i)" using yeah by auto
      also have " = (if ?x = ?xs ! ?n then Suc ?n else if ?x = ?xs ! Suc ?n then ?n else index ?xs ?x)"
        apply(rule index_swap_distinct)
          apply(simp)
          apply(simp add: sis) using indq by linarith
      finally have i': "?i' = (if ?x = ?xs ! ?n then Suc ?n else if ?x = ?xs ! Suc ?n then ?n else index ?xs ?x)" .
      
      let ?i''="index (swaps [index xs q - n..<index xs q] xs) (xs ! i)"


    show "(index xs q < i  i < length xs 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) 
     index xs q < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < length xs) 
    (index xs q = i 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n) 
    (index xs q - Suc n  i  i < index xs q 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = Suc (index xs (xs ! i)) 
     index xs q - Suc n < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i)  index xs q) 
    (i < index xs q - Suc n 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < index xs q - Suc n)"
    apply(intro conjI)
    apply(intro impI) apply(elim conjE) prefer 4 apply(intro impI)  prefer 4 apply(intro impI) apply(elim conjE) 
      prefer 4 apply(intro impI) prefer 4
    proof (goal_cases)
      case 1 
      have indH1: "(index xs q < i  i < length xs 
                      ?i'' =  index xs (xs ! i))" using indH by auto
      assume ass: "index xs q < i" and ass2:"i < length xs"      
      then have a: "?i'' =  index xs (xs ! i)" using indH1 by auto
      also have a': " = i" apply(rule index_nth_id) using ass2 by(auto)
      finally have ii: "?i'' = i" .
      have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq apply (simp add: less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass2 apply(simp)
        apply(rule index_less) 
          apply(simp) using ass2 apply(simp)
          apply(simp)
        using ii ass by auto
      have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq True apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass2 apply(simp)
        apply(rule index_less) 
          apply(simp) using ass2 apply(simp)
          apply(simp)
        using ii ass Suc_diff_Suc True by auto     
        
      have "?i' = index xs (xs ! i)" unfolding i' using fstF sndF a by simp
      then show ?case using a' ass ass2 by auto
    next
      case 2
      have indH2: "index xs q = i  ?i'' = index xs (xs ! i) - n" using indH by auto
      assume "index xs q = i"
      then have ass: "i = index xs q" by auto
      with indH2 have a: "i - n = ?i''" by auto
      from ass have c: "index xs (xs ! i) = i" by auto  
      have "Suc (index xs q - Suc n) = i - n" using ass True Suc_diff_Suc by auto
      also have " = ?i''" using a by auto
      finally have a: "Suc ?n = ?i''" .

      have sndTrue: "?x = ?xs ! Suc ?n" apply(simp add: a)
              apply(rule nth_index[symmetric]) by (simp add: ass)
      have fstFalse: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq True apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass  apply(simp)
        apply(rule index_less) 
          apply(simp) using ass  apply(simp)
          apply(simp)
        using a by auto    

      have "?i' = index xs (xs ! index xs q) - Suc n"
          unfolding i' using sndTrue fstFalse by simp
      with ass show ?case by auto
    next
      case 3
      have indH3: "index xs q - n  i  i < index xs q
                ?i'' = Suc (index xs (xs ! i))" using indH by auto
      assume ass: "index xs q - Suc n  i" and
              ass2: "i < index xs q" 
      from ass2 have ilen: "i < length xs" using indq dual_order.strict_trans by blast
      show ?case 
      proof (cases "index xs q - n  i")
        case False
        then have "i < index xs q - n" by auto
        moreover have "(i < index xs q - n  ?i'' = index xs (xs ! i))" using indH by auto
        ultimately have d: "?i'' = index xs (xs ! i)" by simp
        from False ass have b: "index xs q - Suc n = i" by auto
        have "index xs q < length xs" apply(rule index_less) by (auto)
        have c: "index xs (xs ! i) = i"
          apply(rule index_nth_id) apply(simp) using indq ass2 using less_trans by blast
        from b c d have f: "?i'' = index xs q - Suc n" by auto
        have fstT: "?xs ! ?n = ?x" 
            apply(simp only: f[symmetric]) apply(rule nth_index)
            by (simp add: ilen)

        have "?i' = Suc (index xs q - Suc n)"
          unfolding i' using fstT by simp
        also have " = Suc (index xs (xs ! i))" by(simp only: b c)
        finally show ?thesis using c False ass by auto
      next
        case True
        with ass2 indH3 have a: "?i'' = Suc (index xs (xs ! i))" by auto
        have jo: "index xs (xs ! i) = i" apply(rule index_nth_id) using ilen by(auto)
        have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
          using indq apply (simp add: less_imp_diff_less)
          apply(simp)
          apply(rule nth_index) apply(simp) using ilen apply(simp)
          apply(rule index_less) 
            apply(simp) using ilen apply(simp)
            apply(simp)
          apply(simp only: a jo) using True by auto
        have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
          using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
          apply(simp)
          apply(rule nth_index) apply(simp) using ilen apply(simp)
          apply(rule index_less) 
            apply(simp) using ilen apply(simp)
            apply(simp)
          apply(simp only: a jo) using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
          using True by auto   
        have "?i' = Suc (index xs (xs ! i))" unfolding i' using fstF sndF a by simp 
        then show ?thesis using ass ass2 jo by auto
      qed
    next
      case 4
      assume ass: "i < index xs q - Suc n"
      then have ass2: "i < index xs q - n" by auto
      moreover have "(i < index xs q - n  ?i'' = index xs (xs ! i))" using indH by auto
      ultimately have a: "?i'' = index xs (xs ! i)" by auto
      from ass2 have "i < index xs q" by auto
      then have ilen: "i < length xs" using indq dual_order.strict_trans by blast


      have jo: "index xs (xs ! i) = i" apply(rule index_nth_id) using ilen by(auto)
      have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq apply (simp add: less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ilen apply(simp)
        apply(rule index_less) 
          apply(simp) using ilen apply(simp)
          apply(simp)
        apply(simp only: a jo) using ass by auto 
      have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ilen apply(simp)
        apply(rule index_less) 
          apply(simp) using ilen apply(simp)
          apply(simp)
        apply(simp only: a jo) using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
        using ass by auto  
      have "?i' = (index xs (xs ! i))" unfolding i' using fstF sndF a by simp
      then show ?case using jo ass by auto
    qed
  next
    case False

    then have smalla: "index xs q - Suc n = index xs q - n" by auto
    then have nomore: "swaps [index xs q - Suc n..<index xs q] xs
            =swaps [index xs q - n..<index xs q] xs" by auto
    show "(index xs q < i  i < length xs 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) 
     index xs q < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < length xs) 
    (index xs q = i 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n) 
    (index xs q - Suc n  i  i < index xs q 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = Suc (index xs (xs ! i)) 
     index xs q - Suc n < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i)  index xs q) 
    (i < index xs q - Suc n 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) 
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < index xs q - Suc n)" 
      unfolding nomore smalla by (rule indH)
  qed
next
  case 0
  then show ?case apply(simp)
  proof (safe, goal_cases)
    case 1
    have " index xs (xs ! i) = i" apply(rule index_nth_id) using 1 by auto
    with 1 show ?case by auto
  next
    case 2
    have "xs ! index xs q = q" using 2 by(auto)
    with 2 show ?case by auto
  next
    case 3
    have a: "index xs q < length xs" apply(rule index_less) using 3 by auto
    have "index xs (xs ! i) = i" apply(rule index_nth_id) apply(fact 3(2)) using 3(3) a by auto
    with 3 show ?case by auto
  qed   
qed

lemma mtf2_forward_effect1:
  "q  set xs  distinct xs  index xs q < i  i < length xs 
       index (mtf2 n q xs) (xs ! i) = index xs (xs ! i)  index xs q < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i) < length xs" and    
  mtf2_forward_effect2: "q  set xs  distinct xs  index xs q = i
       index (mtf2 n q xs) (xs!i) = index xs q - n  index xs q - n = index (mtf2 n q xs) (xs!i)" and    
  mtf2_forward_effect3: "q  set xs  distinct xs  index xs q - n  i  i < index xs q
       index (mtf2 n q xs) (xs!i) = Suc (index xs (xs!i))  index xs q - n < index (mtf2 n q xs) (xs!i)  index (mtf2 n q xs) (xs!i)  index xs q" and    
  mtf2_forward_effect4: "q  set xs  distinct xs  i < index xs q - n 
       index (mtf2 n q xs) (xs!i) = index xs (xs!i)  index (mtf2 n q xs) (xs!i) < index xs q - n"
apply(safe) using mtf2_effect by metis+

lemma yes[simp]: "index xs x < length xs 
       (xs!index xs x ) = x" apply(rule nth_index) by (simp add: index_less_size_conv)

lemma mtf2_forward_effect1':
  "q  set xs  distinct xs  index xs q < index xs x  index xs x < length xs 
       index (mtf2 n q xs) x = index xs x  index xs q < index (mtf2 n q xs) x  index (mtf2 n q xs) x < length xs"     
 using mtf2_forward_effect1[where xs=xs and i="index xs x"] yes
 by(auto)

lemma
 mtf2_forward_effect2': "q  set xs  distinct xs  index xs q = index xs x
       index (mtf2 n q xs) (xs!index xs x) = index xs q - n  index xs q - n = index (mtf2 n q xs) (xs!index xs x)"
 using mtf2_forward_effect2[where xs=xs and i="index xs x"] 
by fast

lemma
  mtf2_forward_effect3': "q  set xs  distinct xs  index xs q - n  index xs x  index xs x < index xs q
       index (mtf2 n q xs) (xs!index xs x) = Suc (index xs (xs!index xs x))  index xs q - n < index (mtf2 n q xs) (xs!index xs x)  index (mtf2 n q xs) (xs!index xs x)  index xs q" 
 using mtf2_forward_effect3[where xs=xs and i="index xs x"] 
by fast

lemma    
  mtf2_forward_effect4': "q  set xs  distinct xs  index xs x < index xs q - n 
       index (mtf2 n q xs) (xs!index xs x) = index xs (xs!index xs x)  index (mtf2 n q xs) (xs!index xs x) < index xs q - n"
 using mtf2_forward_effect4[where xs=xs and i="index xs x"] 
by fast


lemma splitit: " (index xs q < i  i < length xs   P)
      (index xs q = i  P)
      (index xs q - n  i  i < index xs q  P)
      (i < index xs q - n  P)
    (i < length xs  P)"
by force


lemma mtf2_forward_beforeq: "q  set xs  distinct xs  i < index xs q 
         index (mtf2 n q xs) (xs!i)  index xs q"
apply (cases "i < index xs q - n")
  using mtf2_forward_effect4 apply force
  using mtf2_forward_effect3 using leI by metis


lemma x_stays_before_y_if_y_not_moved_to_front:
  assumes "q  set xs" "distinct xs" "x  set xs" "y  set xs" "y  q"
   and "x < y in xs"
  shows "x < y in (mtf2 n q xs)"
proof - 
  from assms(3) obtain i where i: "i = index xs x" and i2: "i < length xs" by auto
  from assms(4) obtain j where j: "j = index xs y" and j2: "j < length xs" by auto
  have "x < y in xs  x < y in (mtf2 n q xs)"
  apply(cases i xs rule: splitit[where q=q and n=n])
     apply(simp add: i  assms(1,2) mtf2_forward_effect1' before_in_def)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (metis before_in_def assms(1-3) i j less_imp_diff_less mtf2_effect nth_index set_mtf2)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect2' before_in_def)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect2' before_in_def)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect3' before_in_def)
      apply(rule j2)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (smt before_in_def assms(1-3) i j le_less_trans mtf2_forward_effect1 mtf2_forward_effect3 nth_index set_mtf2)
      using assms(4,5) j apply simp
      apply (smt Suc_leI before_in_def assms(1-3) i j le_less_trans lessI mtf2_forward_effect3 nth_index set_mtf2)
      apply (simp add: before_in_def i j)     
      apply(rule j2)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (smt before_in_def assms(1-3) i j le_less_trans mtf2_forward_effect1 mtf2_forward_effect4 nth_index set_mtf2)
      using assms(4-5) j apply simp
      apply (smt before_in_def assms(1-3) i j le_less_trans less_imp_le_nat mtf2_forward_effect3 mtf2_forward_effect4 nth_index set_mtf2)
      apply (metis before_in_def assms(1-3) i j mtf2_forward_effect4 nth_index set_mtf2)     
      apply(rule j2)
     apply(rule i2) done
   with assms(6) show ?thesis by auto
qed


corollary swapped_by_mtf2: "q  set xs  distinct xs  x  set xs   y  set xs  
      x < y in xs  y < x in (mtf2 n q xs)  y = q"
apply(rule ccontr) using x_stays_before_y_if_y_not_moved_to_front not_before_in by (metis before_in_setD1)

lemma x_stays_before_y_if_y_not_moved_to_front_2dir: "q  set xs  distinct xs  x  set xs   y  set xs  y  q  
      x < y in xs = x < y in (mtf2 n q xs)"
oops

lemma mtf2_backwards_effect1:
  assumes "index xs q < length xs" "q  set xs" "distinct xs" 
    "index xs q < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i) < length xs"
    "i < length xs"
  shows  "index xs q <  i  i  < length xs"
proof -
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i)  index xs q)" by auto
  with assms mtf2_forward_effect3 have 2: "~ (index xs q - n  i  i < index xs q)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q <  i  i  < length xs" by metis
qed

lemma mtf2_backwards_effect2:
  assumes "index xs q < length xs" "q  set xs" "distinct xs" "index (mtf2 n q xs) (xs ! i) = index xs q - n"
    "i < length xs" 
    shows "index xs q = i"
proof - 
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 1: "~ (index xs q < i  i < length xs)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i)  index xs q)" by auto
  with assms mtf2_forward_effect3 have 2: "~ (index xs q - n  i  i < index xs q)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q = i" by metis
qed

lemma mtf2_backwards_effect3:
  assumes "index xs q < length xs" "q  set xs" "distinct xs"
    "index xs q - n < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i)  index xs q"
    "i < length xs"
  shows "index xs q - n  i  i < index xs q"
proof -
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 2: "~ (index xs q <  i  i  < length xs)" by metis
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q - n  i  i < index xs q" by metis
qed


lemma mtf2_backwards_effect4:
  assumes "index xs q < length xs" "q  set xs" "distinct xs"
   "index (mtf2 n q xs) (xs ! i) < index xs q - n"
   "i < length xs" 
  shows "i < index xs q - n"
proof - 
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 2: "~ (index xs q <  i  i  < length xs)" by metis
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i)  index (mtf2 n q xs) (xs ! i)  index xs q)" by auto
  with assms mtf2_forward_effect3 have 3: "~ (index xs q - n  i  i < index xs q)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "i < index xs q - n" by metis
qed

lemma mtf2_backwards_effect4':
 assumes "index xs q < length xs" "q  set xs" "distinct xs"
  "index (mtf2 n q xs) x < index xs q - n"
  "x  set xs"
 shows "(index xs x) < index xs q - n"
 using assms mtf2_backwards_effect4[where xs=xs and i="index xs x"] yes
by auto

lemma 
  assumes distA: "distinct A" and
          asm: "q  set A"
  shows 
      mtf2_mono:  "q< x in A  q < x in (mtf2 n q A)" and
      mtf2_q_after: "index (mtf2 n q A) q =  index A q - n"
proof -

    have lele: "(q < x in A  q < x in swaps [index A q - n..<index A q] A)  (index (swaps [index A q - n..<index A q] A) q =  index A q - n)"
    apply(induct n) apply(simp)
    proof -
      fix n
      assume ind: "(q < x in A  q < x in swaps [index A q - n..<index A q] A)
             index (swaps [index A q - n..<index A q] A) q =  index A q - n"
      then have iH: " q < x in A  q < x in swaps [index A q - n..<index A q] A" by auto
      from ind have indH2: "index (swaps [index A q - n..<index A q] A) q =  index A q - n" by auto

      show "(q < x in A  q < x in swaps [index A q - Suc n..<index A q] A) 
          index (swaps [index A q - Suc n..<index A q] A) q = index A q - Suc n" (is "?part1  ?part2")
      proof (cases "index A q  Suc n")
          case True    
          then have onemore: "[index A q - Suc n..<index A q] = (index A q - Suc n) # [index A q - n..<index A q]"
                using Suc_diff_Suc upt_rec by auto

          from onemore have yeah: "swaps [index A q - Suc n..<index A q] A
              = swap (index A q - Suc n) (swaps  [index A q - n..<index A q] A)" by auto


            from indH2 have gr: "index (swaps [index A q - n..<index A q] A) q =  Suc(index A q - Suc n)" using Suc_diff_Suc True by auto
            have whereisq: "swaps [index A q - n..<index A q] A ! Suc (index A q - Suc n) = q" 
                unfolding gr[symmetric] apply(rule nth_index) using asm by auto

          have indSi: "index A q < length A" using asm index_less by auto
          have 3: "Suc (index A q - Suc n) < length (swaps [index A q - n..<index A q] A)" using True
            apply(auto simp: Suc_diff_Suc asm) using indSi by auto
          have 1: "q  swaps [index A q - n..<index A q] A ! (index A q - Suc n)"
              proof
                assume as: "q = swaps [index A q - n..<index A q] A ! (index A q - Suc n)"
                {
                  fix xs x
                  have "Suc x < length xs  xs ! x = q  xs ! Suc x = q  ¬ distinct xs"  
                  by (metis Suc_lessD index_nth_id n_not_Suc_n)
                } note cool=this

                have "¬ distinct (swaps [index A q - n..<index A q] A)"
                  apply(rule cool[of "(index A q - Suc n)"])
                    apply(simp only: 3)
                    apply(simp only: as[symmetric])
                    by(simp only: whereisq)
                then show "False" using distA by auto 
              qed

          have part1: ?part1
          proof
            assume qx: "q < x in A"
            {  
              fix q x B i
               assume a1: "q < x in B"
               assume a2: "~ q = B ! i"
               assume a3: "distinct B"
               assume a4: "Suc i < length B"

               have "dist_perm B B" by(simp add: a3)
               moreover have "Suc i < length B" using a4 by auto
               moreover have "q < x in B  ¬ (q = B ! i  x = B ! Suc i)" using a1 a2 by auto
               ultimately have "q < x in swap i B"
                using before_in_swap[of B B] by simp
           } note grr=this

            have 2: "distinct (swaps [index A q - n..<index A q] A)" using distA by auto
            

            show "q < x in swaps [index A q - Suc n..<index A q] A"
              apply(simp only: yeah)
              apply(rule grr[OF iH[OF qx]]) using 1 2 3 by auto
           qed


           let ?xs = "(swaps [index A q - n..<index A q] A)"
           let ?n = "(index A q - Suc n)" 
           have "?xs ! Suc ?n = swaps [index A q - n..<index A q] A ! (index (swaps [index A q - n..<index A q] A) q)" 
              using indH2 Suc_diff_Suc True by auto
           also have " = q" apply(rule nth_index) using asm by auto
           finally have sndTrue: "?xs ! Suc ?n = q" .
           have fstFalse: "~ q = ?xs ! ?n" by (fact 1) 


           have "index (swaps [index A q - Suc n..<index A q] A) q
              = index (swap (index A q - Suc n) ?xs) q" by (simp only: yeah) 
           also have " = (if q = ?xs ! ?n then Suc ?n else if q = ?xs ! Suc ?n then ?n else index ?xs q)"
            apply(rule index_swap_distinct)
              apply(simp add: distA)
              by (fact 3)
           also have " = ?n" using fstFalse sndTrue by auto
           finally have part2: ?part2 .

           from part1 part2 show "?part1  ?part2" by simp
        next 
          case False
          then have a: "index A q - Suc n = index A q - n" by auto
          then have b: "[index A q - Suc n..<index A q] = [index A q - n..<index A q]" by auto
          show ?thesis apply(simp only: b a) by (fact ind) 
        qed      
      qed 
 
    show "q < x in A  q < x in (mtf2 n q A)"
        "(index (mtf2 n q A) q) =  index A q - n"
    unfolding mtf2_def  
      using asm lele apply(simp)
      using asm lele by(simp)
qed




subsection "effect of mtf2 on index"

lemma swapsthrough: "distinct xs  q  set xs  index ( swaps [index xs q - entf..<index xs q] xs ) q = index xs q - entf"
proof (induct entf)
  case (Suc e)
  note iH=this
  show ?case
  proof (cases "index xs q - e")
    case 0
    then have "[index xs q - Suc e..<index xs q]
        = [index xs q - e..<index xs q]" by force
    then have "index (swaps [index xs q - Suc e..<index xs q] xs) q
          =  index xs q - e" using Suc by auto
    also have " = index xs q - (Suc e)" using 0 by auto
    finally show "index (swaps [index xs q - Suc e..<index xs q] xs) q = index xs q - Suc e" .
  next
    case (Suc f)

    have gaa: "Suc (index xs q - Suc e) = index xs q - e" using Suc by auto

    from Suc have "index xs q - e  index xs q" by auto
    also have " < length xs" by(simp add: index_less_size_conv iH)
    finally have indle: "index xs q - e < length xs".

    have arg: "Suc (index xs q - Suc e) < length (swaps [index xs q - e..<index xs q] xs)"
      apply(auto) unfolding gaa using indle by simp
    then have arg2: "index xs q - Suc e < length (swaps [index xs q - e..<index xs q] xs)" by auto
    from Suc have nexter: "index xs q - e = Suc (index xs q - (Suc e))" by auto
    then have aaa: "[index xs q - Suc e..<index xs q]
        = (index xs q - Suc e)#[index xs q - e..<index xs q]" using upt_rec by auto

     
    let ?i="index xs q - Suc e"
    let ?rest="swaps [index xs q - e..<index xs q] xs"
    from iH nexter have indj: "index ?rest q = Suc ?i" by auto

    from iH(2) have "distinct ?rest" by auto

    have "?rest ! (index ?rest q) = q" apply(rule nth_index) by(simp add: iH)
    with indj have whichcase: "q = ?rest ! Suc ?i" by auto

    with ‹distinct ?rest have whichcase2: "~ q = ?rest ! ?i" 
          by (metis Suc_lessD arg index_nth_id n_not_Suc_n)

    from aaa have "index (swaps [index xs q - Suc e..<index xs q] xs) q
        = index (swap (index xs q - Suc e) (swaps [index xs q - e..<index xs q] xs)) q" 
          by auto
    also have " = (if q = ?rest ! ?i then (Suc ?i) else if q = ?rest ! (Suc ?i) then ?i else index ?rest q)"
        apply(simp only: swap_def arg if_True)
        apply(rule index_swap_if_distinct)
          apply(simp add: iH)
          apply(simp only: arg2)
          by(simp only: arg)
    also have " = ?i" using whichcase whichcase2 by simp
    finally show "index (swaps [index xs q - Suc e..<index xs q] xs) q =
              index xs q - Suc e" .
  qed
next
  case 0
  show ?case by simp
qed

term "mtf2"
lemma mtf2_moves_to_front: "distinct xs  q  set xs  index (mtf2 (length xs) q xs) q  = 0"
unfolding mtf2_def
proof -
  assume distxs: "distinct xs"
  assume qinxs: "q  set xs"
  have " index (if q  set xs then swaps [index xs q - length xs..<index xs q] xs else xs) q 
    = index ( swaps [index xs q - length xs..<index xs q] xs) q" using qinxs by auto
  also have " = index xs q - (length xs)" apply(rule swapsthrough) using distxs qinxs by auto
  also have " = 0" using index_less_size_conv qinxs by (simp add: index_le_size)
  finally show "index (if q  set xs then swaps [index xs q - length xs..<index xs q] xs else xs) q = 0" .
qed




lemma xy_relativorder_mtf2:
  assumes 
    "qx" "qy" "distinct xs" "xset xs" "yset xs" "qset xs"
  shows "x < y in mtf2 n q xs
          = x < y in xs"
using assms
by (metis before_in_setD2 not_before_in x_stays_before_y_if_y_not_moved_to_front)



lemma mtf2_moves_to_frontm1: "distinct xs  q  set xs  index (mtf2 (length xs -1) q xs) q  = 0"
unfolding mtf2_def
proof -
  assume distxs: "distinct xs"
  assume qinxs: "q  set xs"
  have " index (if q  set xs then swaps [index xs q - (length xs -1)..<index xs q] xs else xs) q 
    = index ( swaps [index xs q - (length xs -1)..<index xs q] xs) q" using qinxs by auto
  also have " = index xs q - (length xs -1)" apply(rule swapsthrough) using distxs qinxs by auto
  also have " = 0" using index_less_size_conv qinxs 
by (metis Suc_pred' gr0I length_pos_if_in_set less_irrefl less_trans_Suc zero_less_diff)
  finally show "index (if q  set xs then swaps [index xs q - (length xs -1)..<index xs q] xs else xs) q = 0" .
qed

lemma mtf2_moves_to_front': "distinct xs  y  set xs  x  set xs  xy  x < y in mtf2 (length xs-1) x xs = True"
using mtf2_moves_to_frontm1 by (metis before_in_def gr0I index_eq_index_conv set_mtf2)

lemma mtf2_moves_to_front'': "distinct xs  y  set xs  x  set xs  xy  x < y in mtf2 (length xs) x xs = True"
using mtf2_moves_to_front by (metis before_in_def gr0I index_eq_index_conv set_mtf2)




end

Theory BIT

(*  Title:       Competitive Analysis of BIT
    Author:      Max Haslbeck
*) 

section "BIT: an Online Algorithm for the List Update Problem"

theory BIT
imports
  Bit_Strings 
  MTF2_Effects
begin
    

abbreviation "config'' A qs init n == config_rand A init (take n qs)"


lemma sum_my: fixes f g::"'b  'a::ab_group_add"
    assumes "finite A" "finite B"
  shows "(xA. f x) - (xB. g x)
    = (x(A  B). f x - g x) + (xA-B. f x) - (xB-A. g x)"
proof -
  have "finite (A-B)" and "finite (AB)" and "finite (B-A)" and "finite (BA)" using assms by auto 
  note finites=this
  have "(A-B)  ( (AB)  ) = {}" and "(B-A)  ( (BA)  ) = {}"  by auto
  note inters=this
  have commute: "AB=BA" by auto
  have "A = (A-B)  (AB)" and "B = (B-A)  ( (BA))"  by auto
  then have "(xA. f x) - (xB. g x) = (x(A-B)  (AB). f x) - (x(B-A)  (BA). g x)" by auto
  also have " = ( (x(A-B). f x) + (x(AB). f x) - (x(A-B)(AB). f x) )
        -( (x(B-A). g x) + (x(BA). g x) - (x(B-A)(BA). g x))" 
          using sum_Un[where ?f="f",OF finites(1) finites(2)]
                sum_Un[where ?f="g",OF finites(3) finites(4)] by(simp)
  also have " = ( (x(A-B). f x) + (x(AB). f x) )
        - (x(B-A). g x) - (x(BA). g x) " using inters by auto
  also have " =  (x(A-B). f x) - (x(AB). g x) + (x(AB). f x) 
        - (x(B-A). g x)  " using commute by auto
  also have " = (x(AB). f x - g x) +(x(A-B). f x) 
        - (x(B-A). g x)" using sum_subtractf[of f g "(AB)"] by auto
  finally show ?thesis .
qed

lemma sum_my2: "(xA. f x = g x)  (xA. f x) = (xA. g x)" by auto


subsection "Definition of BIT" 


definition BIT_init :: "('a state,bool list * 'a list)alg_on_init" where
  "BIT_init init = map_pmf (λl. (l,init)) (bv (length init))"



lemma "~ deterministic_init BIT_init"
unfolding deterministic_init_def BIT_init_def apply(auto)
apply(intro exI[where x="[a]"]) 
  ― ‹comment in a proof›
by(auto simp: UNIV_bool set_pmf_bernoulli)
 
definition BIT_step :: "('a state, bool list * 'a list, 'a, answer)alg_on_step" where
"BIT_step s q = ( let a=((if (fst (snd s))!(index (snd (snd s)) q) then 0 else (length (fst s))),[]) in
                     return_pmf (a , (flip (index (snd (snd s)) q) (fst (snd s)), snd (snd s))))"
                 
lemma "deterministic_step BIT_step"
unfolding deterministic_step_def BIT_step_def
by simp



abbreviation BIT :: "('a state, bool list*'a list, 'a, answer)alg_on_rand" where
    "BIT == (BIT_init, BIT_step)"

 
subsection "Properties of BIT's state distribution"
 
lemma BIT_no_paid: "((free,paid),_)  (BIT_step s q). paid=[]"
unfolding BIT_step_def
by(auto)

subsubsection "About the Internal State"
term "(config'_rand (BIT_init, BIT_step) s0 qs) "
lemma config'_n_init: fixes qs init n
  shows "map_pmf (snd  snd) (config'_rand (BIT_init, BIT_step) init qs) = map_pmf (snd  snd) init"
apply (induct qs arbitrary: init)
  by (simp_all add: map_pmf_def bind_assoc_pmf BIT_step_def bind_return_pmf )   
 

lemma config_n_init: "map_pmf (snd  snd) (config_rand  (BIT_init, BIT_step) s0 qs) = return_pmf s0"
using config'_n_init[of "((fst (BIT_init, BIT_step) s0)  (λis. return_pmf (s0, is)))"] 
  by (simp_all add: map_pmf_def bind_assoc_pmf  bind_return_pmf BIT_init_def )    

lemma config_n_init2: "(_,(_,x))  set_pmf (config_rand (BIT_init, BIT_step) init qs). x = init"
proof (rule, goal_cases)
  case (1 z)
  then have 1: "snd(snd z)  (snd  snd) ` set_pmf (config_rand   (BIT_init, BIT_step) init qs)"
        by force
  have "(snd  snd) ` set_pmf (config_rand  (BIT_init, BIT_step) init qs)
              = set_pmf (map_pmf (snd  snd) (config_rand  (BIT_init, BIT_step) init qs))" by(simp)
  also have " = {init}" apply(simp only: config_n_init) by simp
  finally have "snd(snd z) = init" using 1 by auto 
  then show ?case by auto 
qed 
lemma config_n_init3: "x  set_pmf (config_rand (BIT_init, BIT_step) init qs). snd (snd x) = init"
using config_n_init2 by(simp add: split_def)



lemma config'_n_bv: fixes qs init n 
  shows " map_pmf (snd  snd) init = return_pmf s0
       map_pmf (fst  snd) init = bv (length s0)
       map_pmf (snd  snd) (config'_rand (BIT_init, BIT_step) init qs) = return_pmf s0
         map_pmf (fst  snd) (config'_rand (BIT_init, BIT_step) init qs) = bv (length s0)"
proof (induct qs arbitrary: init)
  case (Cons r rs) 
  from Cons(2) have a: "map_pmf (snd  snd) (init  (λs. snd (BIT_init, BIT_step) s r 
           (λ(a, is'). return_pmf (step (fst s) r a, is'))))
            = return_pmf s0" apply(simp add: BIT_step_def)
              by (simp_all add: map_pmf_def bind_assoc_pmf BIT_step_def bind_return_pmf )  
  then have b: "zset_pmf (init  (λs. snd (BIT_init, BIT_step) s r 
           (λ(a, is'). return_pmf (step (fst s) r a, is')))). snd (snd z) = s0"
     by (metis (mono_tags, lifting) comp_eq_dest_lhs map_pmf_eq_return_pmf_iff)

  show ?case
    apply(simp only: config'_rand.simps)
    proof (rule Cons(1), goal_cases)  
      case 2
      have "map_pmf (fst  snd)
     (init 
      (λs. snd (BIT_init, BIT_step) s r 
           (λ(a, is').
               return_pmf (step (fst s) r a, is')))) = map_pmf (flip (index s0 r)) (bv (length s0))" 
      using b
      apply(simp add: BIT_step_def Cons(3)[symmetric] bind_return_pmf map_pmf_def bind_assoc_pmf )
      apply(rule bind_pmf_cong)
        apply(simp)
        by(simp add: inv_flip_bv)
      also have " = bv (length s0)"  using inv_flip_bv by auto
      finally show ?case  . 
   qed (fact)
qed simp

 
lemma config_n_bv_2: "map_pmf (snd  snd) (config_rand (BIT_init, BIT_step) s0 qs) = return_pmf s0
         map_pmf (fst  snd) (config_rand (BIT_init, BIT_step) s0 qs) = bv (length s0)"
apply(rule config'_n_bv)
  by(simp_all add: bind_return_pmf map_pmf_def bind_assoc_pmf bind_return_pmf' BIT_init_def)


 
lemma config_n_bv: "map_pmf (fst  snd) (config_rand (BIT_init, BIT_step) s0 qs) = bv (length s0)"
using config_n_bv_2 by auto

lemma config_n_fst_init_length: "(_,(x,_))  set_pmf (config_rand (BIT_init, BIT_step) s0 qs). length x = length s0"
proof 
  fix x::"('a list × (bool list × 'a list))"
  assume ass:"x  set_pmf (config_rand (BIT_init, BIT_step) s0 qs)" 
  let ?a="fst (snd x)"
  from ass have "(fst x,(?a,snd (snd x)))  set_pmf (config_rand (BIT_init, BIT_step) s0 qs)" by auto
  with ass have "?a  (fst  snd) ` set_pmf (config_rand (BIT_init, BIT_step) s0 qs)" by force
  then have "?a  set_pmf (map_pmf (fst  snd) (config_rand (BIT_init, BIT_step) s0 qs))" by auto
  then have "?a  bv (length s0)" by(simp only: config_n_bv)
  then have "length ?a = length s0" by (auto simp: len_bv_n)
  then show "case x of (uu_, xa, uua_)  length xa = length s0" by(simp add: split_def)
qed

lemma config_n_fst_init_length2: "x  set_pmf (config_rand (BIT_init, BIT_step) s0 qs). length (fst (snd x)) = length s0"
using config_n_fst_init_length by(simp add: split_def)



lemma fperms: "finite {x::'a list. length x = length init  distinct x  set x = set init}"
apply(rule finite_subset[where B="{xs. set xs  set init  length xs  length init}"])
apply(force) apply(rule finite_lists_length_le) by auto


lemma finite_config_BIT: assumes [simp]: "distinct init"
  shows "finite (set_pmf (config_rand (BIT_init, BIT_step) init qs))" (is "finite ?D")
proof -
  have a: "(fst  snd) ` ?D  {x. length x = length init}" using config_n_fst_init_length2 by force
  have c: "(snd  snd) ` ?D = {init}"
  proof -
    have "(snd  snd) ` set_pmf (config_rand (BIT_init, BIT_step) init qs)
                = set_pmf (map_pmf (snd  snd) (config_rand (BIT_init, BIT_step) init qs))" by(simp)
    also have " = {init}" apply(subst config_n_init) by simp
    finally show ?thesis .
  qed
  from a c have d: "snd ` ?D  {x. length x = length init} × {init}" by force
  have b: "fst ` ?D  {x. length x = length init  distinct x  set x = set init}"
    using config_rand by fastforce

  from b d have "?D  {x. length x = length init  distinct x  set x = set init} × ({x. length x = length init} × {init})"
   by auto
  then show ?thesis
    apply (rule finite_subset)
      apply(rule finite_cartesian_product)
        apply(rule fperms)
        apply(rule finite_cartesian_product)
          apply (rule bitstrings_finite)
          by(simp) 
qed


subsection "BIT is $1.75$-competitive (a combinatorial proof)"
 






subsubsection "Definition of the Locale and Helper Functions"
locale BIT_Off = 
fixes acts :: "answer list"  
fixes qs :: "'a list" 
fixes init :: "'a list" 
assumes dist_init[simp]: "distinct init"
assumes len_acts: "length acts = length qs"
begin


lemma setinit: "(index init) ` set init = {0..<length init}" 
using dist_init
proof(induct init)
  case (Cons a as)
  with Cons have iH: "index as ` set as = {0..<length as}" by auto
  from Cons have 1:"(set as  {x. (a  x)}) = set as" by fastforce
  have 2: "(λa. Suc (index as a)) ` set as =
          (λa. Suc a) ` ((index as) ` set as )" by auto
  show ?case
  apply(simp add: 1 2 iH) by auto
qed simp

definition free_A :: "nat list" where      (* free exchanges of A *)
"free_A = map fst acts"

definition paid_A' :: "nat list list" where  (* paid exchanges of A' *)
"paid_A' = map snd acts"

definition paid_A  :: "nat list list" where  (* paid exchanges of A *)
  "paid_A  = map (filter (λx. Suc x < length init)) paid_A'"

lemma len_paid_A[simp]: "length paid_A = length qs"
unfolding paid_A_def paid_A'_def using len_acts by auto
lemma len_paid_A'[simp]: "length paid_A' = length qs"
unfolding paid_A'_def using len_acts by auto


lemma paidAnm_inbound: "n < length paid_A  m < length(paid_A!n)  (Suc ((paid_A!n)!(length (paid_A ! n) - Suc m))) < length init"
proof -
  assume "n < length paid_A"
  then have "n < length paid_A'" by auto
  then have a: "(paid_A!n)
      = filter (λx. Suc x < length init) (paid_A' ! n)" unfolding paid_A_def by auto 

  let ?filtered="(filter (λx. Suc x < length init) (paid_A' ! n))"
  assume mtt: "m < length (paid_A!n)"
  with a have "(length (paid_A ! n) - Suc m) < length ?filtered" by auto
  with nth_mem have b: "Suc(?filtered ! (length (paid_A ! n) - Suc m)) < length init" by force

  show "Suc (paid_A ! n ! (length (paid_A ! n) - Suc m)) < length init" using a b by auto
qed

fun s_A' :: "nat  'a list" where 
"s_A' 0 = init" |
"s_A'(Suc n) = step (s_A' n) (qs!n) (free_A!n, paid_A'!n)"

lemma length_s_A'[simp]: "length(s_A' n) = length init"
by (induction n) simp_all

lemma dist_s_A'[simp]: "distinct(s_A' n)" 
by(induction n) (simp_all add: step_def)

lemma set_s_A'[simp]: "set(s_A' n) = set init"
by(induction n) (simp_all add: step_def)

fun s_A  :: "nat  'a list" where  
"s_A 0 = init" |
"s_A(Suc n) = step (s_A n) (qs!n) (free_A!n, paid_A!n)"

lemma length_s_A[simp]: "length(s_A n) = length init"
by (induction n) simp_all

lemma dist_s_A[simp]: "distinct(s_A n)" 
by(induction n) (simp_all add: step_def)

lemma set_s_A[simp]: "set(s_A n) = set init"
by(induction n) (simp_all add: step_def)

lemma cost_paidAA': "n < length paid_A'  length (paid_A!n)  length (paid_A'!n)"
  unfolding paid_A_def by simp

lemma swaps_filtered: "swaps (filter (λx. Suc x < length xs) ys) xs = swaps (ys) xs"
apply (induct ys) by auto

lemma sAsA': "n < length paid_A'  s_A' n = s_A n"
proof (induct n)
  case (Suc m) 
  have " s_A' (Suc m)
        =  mtf2 (free_A!m) (qs!m) (swaps (paid_A'!m) (s_A' m))" by (simp add: step_def) 
  also from Suc(2) have " = mtf2 (free_A!m) (qs!m) (swaps (paid_A!m) (s_A' m))"
      unfolding paid_A_def                                   
      by (simp only: nth_map swaps_filtered[where xs="s_A' m", simplified])
  also have " = mtf2 (free_A!m) (qs!m) (swaps (paid_A!m) (s_A m))" using Suc by auto
  also have " = s_A (Suc m)" by (simp add: step_def)
  finally show ?case .
qed simp


lemma sAsA'': "n < length qs  s_A n =  s_A' n"
using sAsA' by auto


definition t_BIT :: "nat  real" where   (* BIT's cost in nth step *)
"t_BIT n = T_on_rand_n BIT init qs n"

definition T_BIT :: "nat  real" where   (* BIT's cost in first n steps *)
"T_BIT n = (i<n. t_BIT i)"


definition c_A :: "nat  int" where 
"c_A n = index (swaps (paid_A!n) (s_A n)) (qs!n) + 1"

definition f_A :: "nat  int" where 
"f_A n = min (free_A!n) (index (swaps (paid_A!n) (s_A n)) (qs!n))"

definition p_A :: "nat  int" where  
"p_A n = size(paid_A!n)"

definition t_A :: "nat  int" where  
"t_A n = c_A n + p_A n"



definition c_A' :: "nat  int" where  
"c_A' n = index (swaps (paid_A'!n) (s_A' n)) (qs!n) + 1"

definition p_A' :: "nat  int" where 
"p_A' n = size(paid_A'!n)"
definition t_A' :: "nat  int"  where  
"t_A' n = c_A' n + p_A' n"
 
lemma t_A_A'_leq: "n < length paid_A'  t_A n  t_A' n"
unfolding t_A_def t_A'_def c_A_def c_A'_def p_A_def p_A'_def
  apply(simp add: sAsA')
  unfolding paid_A_def
  by (simp add: swaps_filtered[where xs="(s_A n)", simplified])

definition T_A' :: "nat  int" where 
"T_A' n = (i<n. t_A' i)"
                                                 
definition T_A :: "nat  int" where 
"T_A n = (i<n. t_A i)"
 
lemma T_A_A'_leq: "n  length paid_A'  T_A n  T_A' n"
unfolding T_A'_def T_A_def apply(rule sum_mono)
by (simp add: t_A_A'_leq)

lemma T_A_A'_leq': "n  length qs  T_A n  T_A' n"
using T_A_A'_leq by auto
 

fun s'_A :: "nat  nat  'a list" where
"s'_A n 0 = s_A n" 
| "(s'_A n (Suc m)) = swap ((paid_A  ! n)!(length (paid_A  ! n) -(Suc m)) ) (s'_A n m)"

lemma set_s'_A[simp]: "set (s'_A n m) = set init"
apply(induct m) by(auto)

lemma len_s'_A[simp]: "length (s'_A n m) = length init"
apply(induct m) by(auto)

lemma distperm_s'_A[simp]: "dist_perm (s'_A n m) init"
apply(induct m) by auto

lemma s'A_m_le: "m  (length (paid_A ! n))  swaps (drop (length (paid_A  ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m"
apply(induct m)
apply(simp)
proof -
  fix m
  assume iH: "(m  length (paid_A ! n)  swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m)"
  assume Suc: "Suc m  length (paid_A ! n)"
  then have "m  length (paid_A ! n)" by auto
  with iH have x: "swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m" by auto
  
  from Suc have mlen: "(length (paid_A ! n) - Suc m) < length (paid_A ! n)" by auto

  let ?l="length (paid_A ! n) - Suc m"
  let ?Sucl="length (paid_A ! n) - m"
  have Sucl: "Suc ?l = ?Sucl" using Suc by auto

  from mlen have yu:  "((paid_A  ! n)! ?l ) # (drop (Suc ?l) (paid_A ! n))
        = (drop ?l (paid_A ! n))" 
    by (rule Cons_nth_drop_Suc)

  from Suc have "s'_A n (Suc m)
      = swap ((paid_A  ! n)!(length (paid_A  ! n) - (Suc m)) ) (s'_A n m)" by auto
  also have " = swap ((paid_A  ! n)!(length (paid_A  ! n) - (Suc m)) )
                    (swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n))"
    by(simp only: x)
  also have " = (swaps (((paid_A  ! n)!(length (paid_A  ! n) - (Suc m)) ) # (drop (length (paid_A ! n) - m) (paid_A ! n))) (s_A n))"
    by auto
  also have " = (swaps (((paid_A  ! n)! ?l ) # (drop (Suc ?l) (paid_A ! n))) (s_A n))"
    using Sucl by auto
  also from mlen have " = (swaps ((drop ?l (paid_A ! n))) (s_A n))"
    by (simp only: yu)
  finally have " s'_A n (Suc m) = swaps (drop (length (paid_A ! n) - Suc m) (paid_A ! n)) (s_A n)" .
  then show " swaps (drop (length (paid_A ! n) - Suc m) (paid_A ! n)) (s_A n) = s'_A n (Suc m)" by auto
qed

lemma s'A_m: "swaps (paid_A ! n) (s_A n) = s'_A n (length (paid_A ! n))"
using s'A_m_le[of "(length (paid_A ! n))" "n", simplified] by auto

 
definition gebub :: "nat  nat  nat" where
  "gebub n m = index init ((s'_A n m)!(Suc ((paid_A!n)!(length (paid_A ! n) - Suc m))))"
 
lemma gebub_inBound: assumes 1: " n < length paid_A " and  2: "m < length (paid_A !  n)" 
          shows "gebub n m < length init"  
proof -
  have "Suc (paid_A ! n ! (length (paid_A ! n) - Suc m)) < length (s'_A n m)" using paidAnm_inbound[OF 1 2] by auto
  then have "s'_A n m ! Suc (paid_A ! n ! (length (paid_A ! n) - Suc m))  set (s'_A n m)" by (rule nth_mem)
  then show ?thesis
      unfolding gebub_def using setinit by auto
qed 
  

subsubsection "The Potential Function"
 
fun phi :: "nat 'a list×  (bool list × 'a list)   real" ("φ")  where
"phi n (c,(b,_)) = ((x,y)(Inv c (s_A n)). (if b!(index init y) then 2 else 1))"

lemma phi': "phi n z = ((x,y)(Inv (fst z) (s_A n)). (if (fst (snd z))!(index init y) then 2 else 1))"
proof -
  have "phi n z = phi n (fst z, (fst(snd z),snd(snd z)))" by (metis prod.collapse)
  also have " = ((x,y)(Inv (fst z) (s_A n)). (if (fst (snd z))!(index init y) then 2 else 1))" by(simp del: prod.collapse)
  finally show ?thesis .
qed

lemma Inv_empty2: "length d = 0  Inv c d = {}"
unfolding Inv_def before_in_def by(auto)

corollary Inv_empty3: "length init = 0  Inv c (s_A n) = {}"
apply(rule Inv_empty2) by (metis length_s_A)

lemma phi_empty2: "length init = 0  phi n (c,(b,i)) = 0"
apply(simp only: phi.simps Inv_empty3) by auto

lemma phi_nonzero: "phi n (c,(b,i))  0"
by (simp add: sum_nonneg split_def)

(* definition of the potential function! *)
definition Phi :: "nat  real" ("Φ") where
"Phi n = E( map_pmf (φ n) (config'' BIT qs init n))"

definition PhiPlus :: "nat  real" ("Φ+") where
"PhiPlus n = (let
        nextconfig = bind_pmf (config'' BIT qs init n)
                (λ(s,is). bind_pmf  (BIT_step (s,is) (qs!n)) (λ(a,nis). return_pmf (step s (qs!n) a,nis)) ) 
                 in
        E( map_pmf (phi (Suc n)) nextconfig) )"

lemma PhiPlus_is_Phi_Suc: "n<length qs  PhiPlus n = Phi (Suc n)"
unfolding PhiPlus_def Phi_def 
apply (simp add: bind_return_pmf map_pmf_def bind_assoc_pmf split_def take_Suc_conv_app_nth )
  apply(simp add: config'_rand_snoc)
  by(simp add: bind_assoc_pmf split_def bind_return_pmf)

lemma phi0: "Phi 0 = 0" unfolding Phi_def 
   by (simp add: bind_return_pmf map_pmf_def bind_assoc_pmf BIT_init_def)

lemma phi_pos: "Phi n  0"
  unfolding Phi_def
  apply(rule E_nonneg_fun)
  using phi_nonzero by auto
  
subsubsection "Helper lemmas"
lemma swap_subs: "dist_perm X Y  Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}"
proof -
  assume "dist_perm X Y"
  note aj = Inv_swap[OF this, of z]                
  show "Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}"
  proof cases
    assume c1: "Suc z < length X"
    show "Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}"
    proof cases
      assume "Y ! z < Y ! Suc z in X"
      with c1 have "Inv X (swap z Y) = Inv X Y  {(Y ! z, Y ! Suc z)}" using aj by auto
      then show "Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}" by auto
    next
      assume "~ Y ! z < Y ! Suc z in X"
      with c1 have "Inv X (swap z Y) = Inv X Y - {(Y ! Suc z, Y ! z)}" using aj by auto
      then show "Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}" by auto
    qed
  next
    assume "~ (Suc z < length X)"
    then have "Inv X (swap z Y) = Inv X Y" using aj by auto
    then show "Inv X (swap z Y)  Inv X Y  {(Y ! z, Y ! Suc z)}" by auto
  qed
qed

 
subsubsection "InvOf"

term "Inv"      (*    BIT A *)
abbreviation "InvOf y bits as  {(x,y)|x. x < y in bits  y < x in as}"

lemma "InvOf y xs ys = {(x,y)|x. (x,y)Inv xs ys}"
unfolding Inv_def by auto

lemma "InvOf y xs ys  Inv xs ys" unfolding Inv_def by auto

lemma numberofIsbeschr: assumes
    distxsys: "dist_perm xs ys" and
    yinxs: "y  set xs"
  shows "index xs y  index ys y + card (InvOf y xs ys)" 
    (is "?iBit  ?iA + card ?I")
proof -
  from assms have distinctxs: "distinct xs" 
      and distinctys: "distinct ys"
      and yinys: "y  set ys" by auto

  let ?A="fst ` ?I"
  have aha: "card ?A = card ?I" apply(rule card_image)
    unfolding inj_on_def by(auto)
      
  have "?A  (before y xs)" by(auto)
  have "?A  (after y ys)" by auto



  have "finite (before y ys)" by auto

  have bef: "(before y xs) - ?A  before y ys" apply(auto)
  proof -
    fix x
    assume a: "x < y in xs"
    assume " x  fst ` {(x, y) |x. x < y in xs  y < x in ys}"
    then have "~ (x < y in xs  y < x in ys)" by force
    with a have d: "~ y < x in ys" by auto
    from a have "x  set xs" by (rule before_in_setD1)
    with distxsys have b: "x  set ys" by auto
    from a have  "y  set xs" by (rule before_in_setD2)
    with distxsys have c: "y  set ys" by auto
    from a have e: "~ x = y" unfolding before_in_def by auto 
    have "(¬ y < x in ys) = (x < y in ys  y = x)" apply(rule not_before_in)
      using b c by auto
    with d e show "x < y in ys" by auto
  qed
 
  have "(index xs y) - card (InvOf y xs ys) = card (before y xs) - card ?A"
    by(simp only: aha card_before[OF distinctxs yinxs])
  also have " = card ((before y xs) - ?A)"
    apply(rule card_Diff_subset[symmetric]) by auto
  also have "  card (before y ys)"
  apply(rule card_mono)
   apply(simp)
   apply(rule bef)
  done
  also have " = (index ys y)" by(simp only: card_before[OF distinctys yinys])
  finally have "index xs y - card ?I  index ys y" .
  then show "index xs y   index ys y + card ?I" by auto
qed
 

lemma "length init = 0  length xs = length init  t xs q (mf, sws) = 1 + length sws"
unfolding t_def by(auto)


lemma integr_index: "integrable (measure_pmf (config'' (BIT_init, BIT_step) qs init n))
   (λ(s, is). real (Suc (index s (qs ! n))))"
    apply(rule measure_pmf.integrable_const_bound[where B="Suc (length init)"])
      apply(simp add: split_def) apply (metis (mono_tags) index_le_size AE_measure_pmf_iff config_rand_length)
      by (auto)
 

subsubsection "Upper Bound on the Cost of BIT"
 

lemma t_BIT_ub2: "(qs!n)  set init  t_BIT n  Suc(size init)"
apply(simp add: t_BIT_def t_def BIT_step_def)
apply(simp add: bind_return_pmf)
proof (goal_cases)
  case 1
  note qs=this
  let ?D =  "(config'' (BIT_init, BIT_step) qs init n)"

  have absch: "(x set_pmf ?D. ((λ(s,is). real (Suc (index s (qs ! n)))) x)  ((λ(is,s). Suc (length init)) x))"
  proof (rule ballI, goal_cases)
    case (1 x) 
    from 1 config_rand_length have f1: "length (fst x) = length init" by fastforce
    from 1 config_rand_set have 2: "set (fst x) = set init" by fastforce

    from qs 2 have "(qs!n)   set (fst x)" by auto
    then show ?case using f1 by (simp add: split_def)
  qed      

  have "integrable (measure_pmf (config'' (BIT_init, BIT_step) qs init n))
     (λ(s, is). Suc (length init))" by(simp)

  have "E(bind_pmf ?D (λ(s, is). return_pmf (real (Suc (index s (qs ! n))))))
          = E(map_pmf (λ(s, is). real (Suc (index s (qs ! n)))) ?D)"
          by(simp add: split_def map_pmf_def)
  also have "  E(map_pmf (λ(s, is). Suc (length init)) ?D)"
              apply (rule E_mono3)
                apply(fact integr_index)
                apply(simp)
                using absch by auto
  also have " = Suc (length init)"
          by(simp add: split_def)
   finally show ?case by(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf split_def)
 qed

lemma t_BIT_ub: "(qs!n)  set init  t_BIT n  size init"
apply(simp add: t_BIT_def t_def BIT_step_def)
apply(simp add: bind_return_pmf)
proof (goal_cases)
  case 1
  note qs=this 
  let ?D =  "(config'' (BIT_init, BIT_step) qs init n)"

  have absch: "(x set_pmf ?D. ((λ(s, is). real (Suc (index s (qs ! n)))) x)  ((λ(s, is). length init) x))"
  proof (rule ballI, goal_cases)
    case (1 x) 
    from 1 config_rand_length have f1: "length (fst x) = length init" by fastforce
    from 1 config_rand_set have 2: "set (fst x) = set init" by fastforce

    from qs 2 have "(qs!n)  set (fst x)" by auto
    then have "(index (fst x) (qs ! n)) < length init" apply(rule index_less) using f1 by auto
    then show ?case by (simp add: split_def)
  qed      

  have "E(bind_pmf ?D (λ(s, is). return_pmf (real (Suc (index s (qs ! n))))))
          = E(map_pmf (λ(s, is). real (Suc (index s (qs ! n)))) ?D)"
          by(simp add: split_def map_pmf_def)
  also have "  E(map_pmf (λ(s, is). length init) ?D)"
              apply(rule E_mono3)
                apply(fact integr_index)
                apply(simp)              
                using absch by auto
  also have " = length init"
          by(simp add: split_def)
   finally show ?case by(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf split_def)
 qed 

lemma T_BIT_ub: "i<n. qs!i  set init  T_BIT n  n * size init"
proof(induction n)
  case 0 show ?case by(simp add: T_BIT_def)
next 
  case (Suc n) thus ?case   
    using t_BIT_ub[where n="n"] by (simp add: T_BIT_def) 
qed
 
 

subsubsection "Main Lemma"
 
                                         
 
lemma myub: "n < length qs  t_BIT n + Phi(n + 1) - Phi n  (7 / 4) * t_A n - 3/4"
proof - 
  assume nqs: "n < length qs"
  have "t_BIT n + Phi (n+1) - Phi n  (7 / 4) * t_A n - 3/4"
  proof (cases "length init > 0")
    case False  
    show ?thesis 
    proof -
      from False have qsn: "(qs!n)  set init" by auto
      from False have l0: "length init = 0" by auto
      then have "length (swaps (paid_A ! n) (s_A n)) = 0" using length_s_A  by auto
  
      with l0 have 4: "t_A n = 1 + length (paid_A ! n)" unfolding t_A_def c_A_def p_A_def by(simp)
  
      have 1: "t_BIT n  1" using t_BIT_ub2[OF qsn] l0 by auto
    
      { fix m
      have "phi m = (λ(b,(a,i)). phi m (b,(a,i)))" by auto
      also have " = (λ(b,(a,i)). 0)" by(simp only: phi_empty2[OF l0])
      finally have "phi m= (λ(b,(a,i)). 0)". 
      } note phinull=this
  
      have 2: "PhiPlus n = 0" unfolding PhiPlus_def apply(simp) apply(simp only: phinull)
      by (auto simp: split_def)
      have 3:"Phi n = 0" unfolding Phi_def apply(simp only: phinull)
      by (auto simp: split_def)
  
      have "t_A n  1  1  7 / 4 *   (t_A n) - 3 / 4" by(simp)
      with 4 have 5: "1  7 / 4 *   (t_A n) - 3 / 4" by auto
  
      from 1 2 3 have "t_BIT n + PhiPlus n - Phi n  1" by auto
      also from 5 have "   7 / 4 *   (t_A n) - 3 / 4" by auto
      
      finally show ?thesis using PhiPlus_is_Phi_Suc nqs by auto
   qed
  next
    case True
    let ?l = "length init"
    from True obtain l' where lSuc: "?l = Suc l'" by (metis Suc_pred)

    have 31: "n < length paid_A" using nqs by auto
 

    define q where "q = qs!n"
    define D where [simp]: "D = (config'' (BIT_init, BIT_step) qs init n)"
    define cost where [simp]: "cost = (λ(s, is).(t s q (if (fst is) ! (index (snd is) q) then 0 else length s, [])))"
    define Φ2 where [simp]: "Φ2 = (λ(s, is). ((phi (Suc n)) (step s q (if (fst is) ! (index (snd is) q) then 0 else length s, []),(flip (index (snd is) q) (fst is), snd is))))"
    define Φ0 where [simp]: "Φ0 = phi n"
           
    have inEreinziehn: "t_BIT n + Phi (n+1) - Phi n =  E (map_pmf (λx. (cost x) + (Φ2 x) - (Φ0 x)) D)"
    proof - 
      have "bind_pmf D
                      (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a,nis). return_pmf (real(t s (q) a))))
         = bind_pmf D
                      (λ(s, is). return_pmf (t s q (if (fst is) ! (index (snd is) q) then 0 else length s, [])))"
            unfolding BIT_step_def apply (auto simp: bind_return_pmf split_def)
              by (metis prod.collapse)
      also have " = map_pmf cost D"  
                     by (auto simp: map_pmf_def split_def)
      finally have rightform1: "bind_pmf D
                      (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a,nis). return_pmf (real(t s (q) a))))
                      = map_pmf cost D" . 

      have rightform2: "map_pmf (phi (Suc n)) (bind_pmf D
          (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a, nis). return_pmf (step s (q) a, nis))))
            = map_pmf Φ2 D" apply(simp add:  bind_return_pmf bind_assoc_pmf map_pmf_def split_def BIT_step_def)
            by (metis  prod.collapse)
      have "t_BIT n + Phi (n+1) - Phi n =
       t_BIT n + PhiPlus n - Phi n" using PhiPlus_is_Phi_Suc nqs by auto
      also have " =
          T_on_rand_n BIT init qs n
         + E (map_pmf (phi (Suc n)) (bind_pmf D
            (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a, nis). return_pmf (step s (q) a, nis)))))
        - E (map_pmf (phi n) D)
        " unfolding  PhiPlus_def Phi_def  t_BIT_def q_def by auto
      also have " = 
        E (bind_pmf D
                      (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a,nis). return_pmf (t s (q) a))))
        + E (map_pmf (phi (Suc n)) (bind_pmf D
            (λ(s, is). bind_pmf (BIT_step (s, is) (q)) (λ(a, nis). return_pmf (step s (q) a, nis)))))
        - E (map_pmf Φ0 D)"  by (auto simp: q_def split_def)
      also have " = E (map_pmf cost D)
                  + E (map_pmf Φ2 D)
                  - E (map_pmf Φ0 D)" using rightform1 rightform2 split_def by auto
      also have " =  E (map_pmf (λx. (cost x) + (Φ2 x)) D) -  E (map_pmf (λx. (Φ0 x)) D)"
            unfolding D_def using E_linear_plus2[OF finite_config_BIT[OF dist_init]] by auto
      also have " =  E (map_pmf (λx. (cost x) + (Φ2 x) - (Φ0 x)) D)"
            unfolding D_def by(simp only: E_linear_diff2[OF finite_config_BIT[OF dist_init]] split_def)
      finally show "t_BIT n + Phi (n+1) - Phi n 
            =  E (map_pmf (λx. (cost x) + (Φ2 x) - (Φ0 x)) D)" by auto
    qed 

    define xs where [simp]: "xs = s_A n"
    define xs' where [simp]: "xs' = swaps (paid_A!n) xs"
    define xs'' where [simp]: "xs'' = mtf2 (free_A!n) (q) xs'"
    define k where [simp]: "k = index xs' q"    (* position of the requested element in A's list *)
    define k' where [simp]: "k' = max 0 (k-free_A!n)" (* position where A moves the requested element to *)

    have [simp]: "length xs = length init" by auto

    have dp_xs_init[simp]: "dist_perm xs init" by auto
  

text "The Transformation"
 
    have ub_cost: "xset_pmf D. (real (cost x)) + (Φ2 x) - (Φ0 x)  k + 1 + 
            (if (q)  set init
              then (if (fst (snd x))!(index init q) then k-k' 
                                      else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))
              else 0)
              + (i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2 else 1))"
    proof (rule, goal_cases)
      case (1 x)
      note xinD=1 
      then have [simp]: "snd (snd x) = init" using D_def config_n_init3 by fast

      define b where "b = fst (snd x)"
      define ys where "ys = fst x"
      define aBIT where [simp]: "aBIT = (if b ! (index (snd (snd x)) q) then 0 else length ys, ([]::nat list))"
      define ys' where "ys' = step ys (q) aBIT"
      define b' where "b' = flip (index init q) b"
      define Φ1 where "Φ1 = (λz:: 'a list× (bool list × 'a list) . ((x,y)(Inv ys xs'). (if fst (snd z)!(index init y) then 2::real else 1)))"

      have xs''_step: "xs'' = step xs (q) (free_A!n,paid_A!n)"
      unfolding xs'_def xs''_def xs_def step_def free_A_def paid_A_def
      by(auto simp: split_def)

      have gis2: "(Φ2 (ys,(b,init))) = ((x,y)(Inv ys' xs''). (if b'!(index init y) then 2 else 1))" 
        apply(simp only: split_def)
        apply(simp only: xs''_step)
        apply(simp only: Φ2_def phi.simps)
        unfolding b'_def b_def ys'_def aBIT_def q_def
        unfolding s_A.simps apply(simp only: split_def) by auto
      then have gis: "Φ2 x = ((x,y)(Inv ys' xs''). (if b'!(index init y) then 2 else 1))"
        unfolding ys_def b_def by (auto simp: split_def)

      have his2: "(Φ0 (ys,(b,init))) = ((x,y)(Inv ys xs). (if b!(index init y) then 2 else 1))"
        apply(simp only: split_def)
        apply(simp only: Φ0_def phi.simps) by(simp add: split_def)
      then have his: "(Φ0 x) = ((x,y)(Inv ys xs). (if b!(index init y) then 2 else 1))"  
        by(auto simp: ys_def b_def split_def phi')
          
      have dis: "Φ1 x = ((x,y)(Inv ys xs'). (if b!(index init y) then 2 else 1))"
        unfolding Φ1_def b_def by auto
  
      have "ys' = mtf2 (fst aBIT) (q) ys" by (simp add: step_def ys'_def) 

      from config_rand_distinct[of BIT] config_rand_set[of BIT] xinD
      have dp_ys_init[simp]: "dist_perm ys init" unfolding D_def ys_def by force
      have dp_ys'_init[simp]: "dist_perm ys' init" unfolding ys'_def step_def by (auto)
      then have lenys'[simp]: "length ys' = length init" by (metis distinct_card)
      have dp_xs'_init[simp]: "dist_perm xs' init" by auto
      have gra: "dist_perm ys xs'" by auto

      have leninitb[simp]: "length b = length init" using b_def config_n_fst_init_length2 xinD[unfolded] by auto
      have leninitys[simp]: "length ys = length init" using dp_ys_init by (metis distinct_card)

      {fix m
        have "dist_perm ys (s'_A n m)" using dp_ys_init by auto
      } note dist=this
 
      text "Upper bound of the inversions created by paid exchanges of A"

      (* ============================================

          first we adress the paid exchanges 
          
          paid cost of A: p_A *)
     

      let ?paidUB="(i<(length (paid_A!n)). (if b!(gebub n i) then 2::real else 1))"

      have paid_ub: "Φ1 x  Φ0 x + ?paidUB"
      proof -
      
        have a: "length (paid_A ! n)  length (paid_A ! n)" by auto
        have b: "xs' = (s'_A n (length (paid_A ! n)))" using s'A_m by auto
 
        {
          fix m
          have "mlength (paid_A!n)  ((x,y)(Inv ys (s'_A n m)). (if b!(index init y) then 2::real else 1))  ((x,y)(Inv ys xs). (if b!(index init y) then 2 else 1))
                              + (i<m. (if b!(gebub n i) then 2 else 1))"
        proof (induct m)
          case (Suc m)
          then have m_bd2: "m  length (paid_A ! n)"
                and m_bd: "m < length (paid_A ! n)" by auto
          note yeah = Suc(1)[OF m_bd2]  

          let ?revm="(length (paid_A ! n) - Suc m)"
          note ah=Inv_swap[of "ys" "(s'_A n m)" "(paid_A ! n ! ?revm)", OF dist]
          have "((xa, y)Inv ys (s'_A n (Suc m)). if b ! (index init y) then 2::real else 1)
              = ((xa, y)Inv ys (swap (paid_A ! n ! ?revm) (s'_A n m)). if b ! (index init y) then 2 else 1)" using s'_A.simps(2) by auto
          also
          have " = ((xa, y)(if Suc (paid_A ! n ! ?revm) < length ys
   then if s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys
        then Inv ys (s'_A n m)  {(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))}
        else Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
   else Inv ys (s'_A n m)). if b ! (index init y) then 2::real else 1)" by (simp only: ah)
          also
          have "  ((xa, y)Inv ys (s'_A n m). if b ! (index init y) then 2::real else 1)
                        + (if (b) ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" (is "?A  ?B")
               proof(cases "Suc (paid_A ! n ! ?revm) < length ys")
                case False (* FIXME! can't occur! because it has already been filtered out! see:
                 then have "False" using paidAnm_inbound apply(auto) using m_bd nqs by blast *)
                then have "?A = ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
                also have "  ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1) +
                        (if b ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" by auto
                finally show "?A  ?B" .
               next
                case True
                then have "?A = ((xa, y)(if s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys
                      then Inv ys (s'_A n m)  {(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))}
                      else Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
                        ). if b ! (index init y) then 2 else 1)" by auto
                also have "  ?B" (is "?A'  ?B")
                proof (cases "s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys")
                  case True
                  let ?neurein="(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))"
                  from True have "?A' = ((xa, y)(Inv ys (s'_A n m)  {?neurein}
                      ). if b ! (index init y) then 2 else 1)" by auto
                  also have " = ((xa, y)insert ?neurein (Inv ys (s'_A n m)
                      ). if b ! (index init y) then 2 else 1)" by auto
                  also have "  (if b ! (index init (snd ?neurein)) then 2 else 1) 
                            + ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)"
                  proof (cases "?neurein  Inv ys (s'_A n m)")
                    case True
                    then have "insert ?neurein (Inv ys (s'_A n m)) = (Inv ys (s'_A n m))" by auto
                    then have "((xa, y)insert ?neurein (Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)
                        = ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
                    also have "  (if b ! (index init (snd ?neurein)) then 2::real else 1) 
                            + ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
                    finally show ?thesis .
                  next
                    case False
                    have "((xa, y)insert ?neurein (Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)
                        = (yinsert ?neurein (Inv ys (s'_A n m)). (λi. if b ! (index init (snd i)) then 2 else 1) y)" by(auto simp: split_def)
                    also have " = (λi. if b ! (index init (snd i)) then 2 else 1) ?neurein
                            + (y(Inv ys (s'_A n m)) - {?neurein}. (λi. if b ! (index init (snd i)) then 2 else 1) y)"
                            apply(rule sum.insert_remove) by(auto)
                    also have " = (if b ! (index init (snd ?neurein)) then 2 else 1) 
                            + (y(Inv ys (s'_A n m)). (λi. if b ! (index init (snd i)) then 2::real else 1) y)" using False by auto
                    also have "  (if b ! (index init (snd ?neurein)) then 2 else 1) 
                            + ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by(simp only: split_def)
                    finally show ?thesis .
                  qed                  
                  also have " = ((xa, y)Inv ys (s'_A n m). if b ! (index init y) then 2 else 1) +
                        (if b ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2 else 1)" by auto
                  finally show ?thesis .
                next
                  case False
                  then have "?A' = ((xa, y)(Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
                        ). if b ! (index init y) then 2 else 1)" by auto
                  also have "  ((xa, y)(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" (is "((xa, y)?X-{?x}. ?g y)  ((xa, y)?X. ?g y) ")
                  proof (cases "?x  ?X")                  
                    case True
                    have "((xa, y)?X-{?x}. ?g y)  (%(xa,y). ?g y) ?x + ((xa, y)?X-{?x}. ?g y)"
                       by simp
                    also have " = ((xa, y)?X. ?g y)"
                      apply(rule sum.remove[symmetric])
                        apply simp apply(fact) done
                    finally show ?thesis .
                  qed simp 
                  also have "  ?B" by auto
                  finally show ?thesis .
                qed                   
                finally show "?A  ?B" .
              qed 

          also have " 
               ((xa, y)Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (i<m. if b ! gebub n i then 2::real else 1)
                        + (if (b) ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" using yeah by simp
          also have " = ((xa, y)Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (i<m. if b ! gebub n i then 2 else 1)
                        + (if (b) ! gebub n m then 2 else 1)" unfolding gebub_def by simp
          also have " = ((xa, y)Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (i<(Suc m). if b ! gebub n i then 2 else 1)"
                        by auto 
          finally show ?case by simp
        qed (simp add: split_def) 
        } note x = this[OF a]

        show ?thesis
          unfolding Φ1_def his apply(simp only: b) using x b_def by auto
      qed

      text "Upper bound for the costs of BIT"

      define inI where [simp]: "inI = InvOf (q) ys xs'"
      define I where [simp]: "I = card(InvOf (q) ys xs')" 
            (* ys is BITs list, xs' is A's list after paid exchanges *)

      have ub_cost_BIT:  "(cost x)  k + 1 + I"
      proof (cases "(q)  set init")
        case False (* cannot occur! ! ! OBSOLETE *)
        from False have 4: "I = 0" by(auto simp: before_in_def)
        have "(cost x) = 1 + index ys (q)" by (auto simp: ys_def t_def split_def)
        also have " = 1 + length init" using False by auto
        also have " = 1 + k" using False by auto
        finally show ?thesis using 4 by auto
      next 
        case True
        then have gra2: "(q)  set ys" using dp_ys_init by auto
        have "(cost x) = 1 + index ys (q)" by(auto simp:  ys_def t_def split_def)
        also have "  k + 1 + I" using numberofIsbeschr[OF gra gra2] by auto
        finally show"(cost x)  k + 1 + I" . 
      qed

      text "Upper bound for inversions generated by free exchanges"

  (* ================================================ *)
      (* ================================================ *)

      (* second part: FREE EXCHANGES *)
 
      define ub_free
        where "ub_free =
          (if (q  set init)
           then (if b!(index init q) then  k-k' else (j<k'. (if (b)!(index init (xs'!j)) then 2::real else 1) ))
           else 0)"
      let ?ub2 = "- I + ub_free"
      have free_ub: "((x,y)(Inv ys' xs''). (if b' !(index init y) then 2 else 1 ) )
                - ((x,y)(Inv ys xs'). (if b!(index init y) then 2 else 1) )  ?ub2"
      proof (cases "(q)  set init")
        case False

        from False have 1: "ys' = ys" unfolding ys'_def step_def mtf2_def by(simp)
        from False have 2: "xs' = xs''" unfolding xs''_def mtf2_def by(simp)
        from False have "(index init q)  length b" using setinit by auto
        then have 3: "b' = b" unfolding b'_def using flip_out_of_bounds by auto

        from False have 4: "I = 0" unfolding I_def before_in_def by(auto)
 
        note ubnn=False

        have nn: "k-k'0" unfolding k_def k'_def by auto
          
        from 1 2 3 4 have "((x,y)(Inv ys' xs''). (if b'!(index init y) then 2::real else 1))
                - ((x,y)(Inv ys xs'). (if b!(index init y) then 2 else 1)) = -I"  by auto
        with ubnn show ?thesis unfolding ub_free_def by auto
      next
        case True 
        note queryinlist=this


        then have gra2: "q  set ys" using dp_ys_init by auto

        have k_inbounds: "k < length init" 
            using index_less_size_conv  queryinlist
              by (simp)
      {
          fix y  e
          fix X::"bool list"
          assume rd: "e < length X"
        have "y < length X  (if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
              = (if e=y then (if X ! y then -1 else 1) else 0)"
          proof cases
             assume "y < length X" and ey: "e=y"
             then have "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
                      = (if X ! y then 1::real else 2) - (if X ! y then 2 else 1)" using flip_itself by auto
             also have " = (if X ! y then -1::real else 1)" by auto
             finally
             show "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
              = (if e=y then (if X ! y then -1 else 1) else 0)" using ey by auto
          next
             assume len: "y < length X" and eny: "ey"
             then have "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
                      = (if X ! y then 2::real else 1) - (if X ! y then 2 else 1)" using flip_other[OF len rd eny]  by auto
             also have " = 0" by auto
             finally
             show "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
              = (if e=y then (if X ! y then -1 else 1) else 0)" using eny by auto
          qed
       } note flipstyle=this
      
      from queryinlist setinit have qsfst: "(index init q) < length b" by simp

      have fA: "finite (Inv ys' xs'')" by auto
      have fB: "finite (Inv ys xs')" by auto


      define Δ where [simp]: "Δ = ((x,y)(Inv ys' xs''). (if b'!(index init y) then 2::real else 1))
                - ((x,y)(Inv ys xs'). (if b!(index init y) then 2 else 1))"
      define C where [simp]: "C = ((x,y)(Inv ys' xs'')  (Inv ys xs'). (if b'!(index init y) then 2::real else 1)
                        - (if b!(index init y) then 2 else 1))"
      define A where [simp]: "A = ((x,y)(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))"
      define B where [simp]: "B = ((x,y)(Inv ys xs')-(Inv ys' xs''). (if b!(index init y) then 2::real else 1))"
        have teilen: "Δ = C + A - B"  (* C A B *)
              unfolding Δ_def A_def B_def C_def
                     using sum_my[OF fA fB]  by (auto simp: split_def)
        then have "Δ = A - B + C" by auto  
        then have teilen2: "Φ2 x - Φ1 x  = A - B + C" unfolding Δ_def using dis gis by auto
 
             
        have setys': "(index init) ` (set ys') = {0..<length ys'}"
          proof -
            have "(index init) ` (set ys') = (index init) ` (set init)" by auto
            also have " = {0..<length init}" using setinit by auto
            also have " = {0..<length ys'}" using lenys' by auto
            finally show ?thesis .
          qed
 
        have BC_absch: "C - B  -I"

        proof (cases "b!(index init q)")    (* case distinction on whether the bit of the requested element is set *)
          case True
          then have samesame: "ys' = ys" unfolding ys'_def step_def by auto
          then have puh: "(Inv ys' xs') = (Inv ys xs')" by auto

          {
             fix α β
             assume "(α,β)(Inv ys' xs'')  (Inv ys' xs')"
             then have "(α,β)(Inv ys' xs'')" by auto
             then have "(α< β in ys')" unfolding Inv_def by auto
             then have 1: "β  set ys'" by (simp only: before_in_setD2)
             then have  "index init β < length ys'" using setys' by auto
             then have  "index init β < length init" using lenys' by auto
             then have puzzel: "index init β < length b" using leninitb by auto


             have betainit: "β  set init" using 1 by auto
             have aha: "(q=β) = (index init q = index init β)"
                using betainit by simp

             have "(if b'!(index init β) then 2::real else 1) - (if b!(index init β) then 2 else 1)
                = (if (index init q) = (index init β) then if b !(index init β) then - 1 else 1 else 0)" 
                  unfolding b'_def apply(rule flipstyle) by(fact)+
             also have " = (if (index init q) = (index init β) then if b ! (index init q) then - 1 else 1 else 0)" by auto
             also have " = (if q = β then - 1 else 0)" using aha True by auto
             finally have "(if b'!(index init β) then 2::real else 1) - (if b!(index init β) then 2 else 1)
                = (if (q) = β then -1::real else 0)" by auto
          }
          then have grreeeaa: "x(Inv ys' xs'')  (Inv ys' xs').
              (λx. (if b'! (index init (snd x)) then 2::real else 1) - (if b! (index init (snd x)) then 2 else 1)) x
                = (λx. (if (q) = snd x then -1::real else 0)) x" by force

          let ?fin="(Inv ys' xs'')  (Inv ys' xs')"

          have ttt: "{(x,y). (x,y)(Inv ys' xs'')  (Inv ys' xs')
                           y = (q)}  {(x,y). (x,y)(Inv ys' xs'')  (Inv ys' xs')
                           y  (q)} = (Inv ys' xs'')  (Inv ys' xs')" (is "?split1  ?split2 = ?easy")  by auto
          have interem: "?split1  ?split2 = {}" by auto
          have split1subs: "?split1  ?fin" by auto
          have split2subs: "?split2  ?fin" by auto
          have fs1: "finite ?split1" apply(rule finite_subset[where B="?fin"])
            apply(rule split1subs) by(auto)
          have fs2: "finite ?split2"  apply(rule finite_subset[where B="?fin"])
            apply(rule split2subs) by(auto)  
  
          have "k - k'  (free_A!n)" by auto

          have g: "InvOf (q) ys' xs''  InvOf (q) ys' xs'"
            using True apply(auto) apply(rule mtf2_mono[of "swaps (paid_A ! n) (s_A n)"])
              by (auto simp: queryinlist)
          have h: "?split1 = (InvOf (q) ys' xs'')  (InvOf (q) ys' xs')" 
            unfolding Inv_def by auto
          also from g have " = InvOf (q) ys' xs'" by force
          also from samesame have " = InvOf (q) ys  xs'" by simp
          finally have "?split1 = inI" unfolding inI_def .
          then have cardsp1isI: "card ?split1 = I" by auto
          
          {
            fix a b
            assume "(a,b)?split1"
            then have "b = (q)" by auto
            then have "(if (q) = b then (-1::real) else 0) = (-1::real)" by auto
          }  
          then have split1easy: "x?split1.
              (λx. (if (q) = snd x then (-1::real) else 0)) x = (λx. (-1::real)) x" by force
          {
            fix a b
            assume "(a,b)?split2"
            then have "~ b = (q)" by auto
            then have "(if (q) = b then (-1::real) else 0) = 0" by auto
          }
          then have split2easy: "x?split2.
              (λx. (if (q) = snd x then (-1::real) else 0)) x = (λx. 0::real) x" by force

                
          have E0: "C =
              ((x,y)(Inv ys' xs'')  (Inv ys xs'). 
                      (if b'!(index init y) then 2::real else 1) - (if b!(index init y) then 2 else 1))" by auto
          also from puh have E1: "... =
              ((x,y)(Inv ys' xs'')  (Inv ys' xs'). 
                      (if b'!(index init y) then 2::real else 1) - (if b!(index init y) then 2 else 1))" by auto
          also have E2: " = ((x,y)?easy. 
                      (if (q) = y then (-1::real) else 0))" using sum_my2[OF grreeeaa] by (auto simp: split_def)
          also have E3: " = ((x,y)?split1  ?split2. 
                      (if (q) = y then (-1::real) else 0))" by(simp only: ttt)
          also have " = ((x,y)?split1. (if (q) = y then (-1::real) else 0))
                    + ((x,y)?split2. (if (q) = y then (-1::real) else 0))
                    - ((x,y)?split1  ?split2. (if (q) = y then (-1::real) else 0))"
                    by(rule sum_Un[OF fs1 fs2]) 
          also have " = ((x,y)?split1. (if (q) = y then (-1::real) else 0))
                    + ((x,y)?split2. (if (q) = y then (-1::real) else 0))"
                    apply(simp only: interem) by auto
          also have E4: " = ((x,y)?split1. (-1::real) )
                    + ((x,y)?split2. 0)"
                 using sum_my2[OF split1easy]sum_my2[OF split2easy] by(simp only: split_def)
          also have " = ((x,y)?split1. (-1::real) )" by auto
          also have E5: " = - card ?split1 " by auto
          also have E6: " = - I " using cardsp1isI by auto
          finally have abschC: "C = -I".

          have abschB: "B  (0::real)" unfolding B_def apply(rule sum_nonneg) by auto  
 
          from abschB abschC show "C - B  -I" by simp

        next
          case False
          from leninitys False have ya: "ys' = mtf2 (length ys) q ys"
              unfolding step_def ys'_def by(auto)
          have "index ys' q = 0" 
            unfolding ya apply(rule mtf2_moves_to_front) 
            using gra2 by simp_all
          then have nixbefore: "before q ys' = {}" unfolding before_in_def by auto

          {
             fix α β
             assume "(α,β)(Inv ys' xs'')  (Inv ys xs')"
             then have "(α,β)(Inv ys' xs'')" by auto
             then have "(α< β in ys')" unfolding Inv_def by auto
             then have 1: "β  set ys'" by (simp only: before_in_setD2)
             then have  "(index init β) < length ys'" using setys' by auto
             then have  "(index init β) < length init" using lenys' by auto
             then have puzzel: "(index init β) < length b" using leninitb by auto


             have betainit: "β  set init" using 1 by auto 
             have aha: "(q=β) = (index init q = index init β)"
                using betainit by simp 

             have "(if b'!(index init β) then 2::real else 1) - (if b!(index init β) then 2 else 1)
                = (if (index init q) = (index init β) then if b ! (index init β) then - 1 else 1 else 0)" 
                  unfolding b'_def apply(rule flipstyle) by(fact)+
             also have " = (if (index init q) = (index init β) then if b ! (index init q) then - 1 else 1 else 0)" by auto
             also have " = (if (q) = β then 1 else 0)" using False aha by auto
             finally have "(if b'!(index init β) then 2::real else 1) - (if b!(index init β) then 2 else 1)
                = (if (q) = β then 1::real else 0)" by auto
          } 
          then have grreeeaa2: "x(Inv ys' xs'')  (Inv ys xs').
              (λx. (if b'! (index init (snd x)) then 2::real else 1) - (if b! (index init (snd x)) then 2 else 1)) x
                = (λx. (if (q) = snd x then 1::real else 0)) x" by force

          let ?fin="(Inv ys' xs'')  (Inv ys xs')"

          have ttt: "{(x,y). (x,y)(Inv ys' xs'')  (Inv ys  xs')
                           y = (q)}  {(x,y). (x,y)(Inv ys' xs'')  (Inv ys  xs')
                           y  (q)} = (Inv ys' xs'')  (Inv ys  xs')" (is "?split1  ?split2 = ?easy")  by auto
          have interem: "?split1  ?split2 = {}" by auto
          have split1subs: "?split1  ?fin" by auto
          have split2subs: "?split2  ?fin" by auto
          have fs1: "finite ?split1" apply(rule finite_subset[where B="?fin"])
            apply(rule split1subs) by(auto)
          have fs2: "finite ?split2"  apply(rule finite_subset[where B="?fin"])
            apply(rule split2subs) by(auto)  
         
          have split1easy : "x?split1.
              (λx. (if (q) = snd x then (1::real) else 0)) x = (λx. (1::real)) x" by force

          have split2easy : "x?split2.
              (λx. (if (q) = snd x then (1::real) else 0)) x = (λx. (0::real)) x" by force



          from nixbefore have InvOfempty: "InvOf q ys' xs'' = {}" unfolding Inv_def by auto

          have "?split1 = InvOf q ys' xs''  InvOf q ys xs'" 
              unfolding Inv_def by auto
          also from InvOfempty have " = {}" by auto
          finally have split1empty: "?split1 = {}" .

          have "C  = ((x,y)?easy. 
                      (if (q) = y then (1::real) else 0))" unfolding C_def by(simp only: split_def sum_my2[OF grreeeaa2])
          also have " = ((x,y)?split1  ?split2. 
                      (if (q) = y then (1::real) else 0))" by(simp only: ttt)
          also have " = ((x,y)?split1. (if (q) = y then (1::real) else 0))
                    + ((x,y)?split2. (if (q) = y then (1::real) else 0))
                    - ((x,y)?split1  ?split2. (if (q) = y then (1::real) else 0))"
                    by(rule sum_Un[OF fs1 fs2]) 
          also have " = ((x,y)?split1. (if (q) = y then (1::real) else 0))
                    + ((x,y)?split2. (if (q) = y then (1::real) else 0))"
                    apply(simp only: interem) by auto 
          also have " = ((x,y)?split1. (1::real) )
                    + ((x,y)?split2. 0)" using sum_my2[OF split1easy] sum_my2[OF split2easy] by (simp only: split_def) 
          also have " = ((x,y)?split1. (1::real) )" by auto
          also have " = card ?split1" by auto
          also have " = (0::real)" apply(simp only: split1empty) by auto
          finally have abschC: "C = (0::real)" .
          
          (* approx for B *)

          have ttt2: "{(x,y). (x,y)(Inv ys  xs') - (Inv ys' xs'')
                           y = (q)}  {(x,y). (x,y)(Inv ys  xs') - (Inv ys' xs'')
                           y  (q)} = (Inv ys  xs') - (Inv ys' xs'')" (is "?split1  ?split2 = ?easy2")  by auto
          have interem: "?split1  ?split2 = {}" by auto
          have split1subs: "?split1  ?easy2" by auto
          have split2subs: "?split2  ?easy2" by auto
          have fs1: "finite ?split1" apply(rule finite_subset[where B="?easy2"])
            apply(rule split1subs) by(auto)
          have fs2: "finite ?split2"  apply(rule finite_subset[where B="?easy2"])
            apply(rule split2subs) by(auto)  
             
          from False have split1easy2: "x?split1.
              (λx. (if b! (index init (snd x)) then 2::real else 1)) x = (λx. (1::real)) x" by force

          have "?split1 = (InvOf q ys  xs') - (InvOf q ys' xs'')" 
              unfolding Inv_def by auto
          also have " =  inI" unfolding InvOfempty by auto 
          finally have splI: "?split1 = inI" .

          have abschaway: "((x,y)?split2. (if b!(index init y) then 2::real else 1))  0"
              apply(rule sum_nonneg) by auto
          
         have "B  =  ((x,y)?split1  ?split2. 
                      (if b!(index init y) then 2::real else 1) )" unfolding B_def by(simp only: ttt2)
          also have " = ((x,y)?split1. (if b!(index init y) then 2::real else 1))
                    + ((x,y)?split2. (if b!(index init y) then 2::real else 1))
                    - ((x,y)?split1  ?split2. (if b!(index init y) then 2::real else 1))"
                    by(rule sum_Un[OF fs1 fs2]) 
          also have " = ((x,y)?split1. (if b!(index init y) then 2::real else 1))
                    + ((x,y)?split2. (if b!(index init y) then 2::real else 1))"
                    apply(simp only: interem) by auto 
          also have " = ((x,y)?split1. 1)
                    + ((x,y)?split2. (if b!(index init y) then 2::real else 1))"
                 using sum_my2[OF split1easy2] by (simp only: split_def)
          also have " = card ?split1
                    + ((x,y)?split2. (if b!(index init y) then 2::real else 1))" by auto
          also have " = I
                    + ((x,y)?split2. (if b!(index init y) then 2::real else 1))" using splI by auto
          also have "  I" using abschaway by auto
          finally have abschB: "B  I" .

          from abschB abschC show "C - B  -I" by auto
        qed
 

        (* ==========================================
            central! calculations for A 
           ========================================== *)
 
        have A_absch: "A
               (if b!(index init q) then k-k' else (j<k'. (if b!(index init (xs'!j)) then 2::real else 1)))"
        proof (cases "b!(index init q)") (* case distinction on whether the requested element's bit is set *)
          case False
 
          from leninitys False have ya: "ys' = mtf2 (length ys) q ys" (* BIT moves q to front *)
              unfolding step_def ys'_def by(auto)
          have "index ys' q = 0" unfolding ya apply(rule mtf2_moves_to_front) 
             using gra2 by(simp_all)
          then have nixbefore: "before q ys' = {}" unfolding before_in_def by auto
          
          have "A = ((x,y)(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto
          

          have "index (mtf2 (free_A ! n) (q) (swaps (paid_A ! n) (s_A n))) (q)
              = (index (swaps (paid_A ! n) (s_A n)) (q) - free_A ! n)" 
                apply(rule mtf2_q_after) using queryinlist by auto
          then have whatisk': "k' = index xs'' q" by auto


          have ss: "set ys' = set ys" by auto
          have ss2: "set xs' = set xs''" by auto

          have di: "distinct init" by auto
          have dys: "distinct ys" by auto

          have "(Inv ys' xs'')-(Inv ys xs')
              = {(x,y). x < y in ys'  y < x in xs''  (~x < y in ys  ~ y < x in xs')}"
              unfolding Inv_def by auto 
          also have "  = 
            {(x,y). yq  x < y in ys'  y < x in xs''  (~x < y in ys  ~ y < x in xs') }"
              using nixbefore by blast
          also have "  = 
            {(x,y). xy  yq  x < y in ys'  y < x in xs''  (~x < y in ys  ~ y < x in xs') }"
              unfolding before_in_def by auto
          also have "  = 
            {(x,y). xy  yq  x < y in ys'  y < x in xs''  ~x < y in ys }
             {(x,y). xy  yq  x < y in ys'  y < x in xs''   ~ y < x in xs' }"
              by force
          also have "  = 
            {(x,y). xy  yq  x < y in ys'  y < x in xs''  y < x in ys }
             {(x,y). xy  yq  x < y in ys'  y < x in xs''   ~ y < x in xs' }"
              using  before_in_setD1[where xs="ys'"] before_in_setD2[where xs="ys'"] not_before_in ss by metis
          also have "  = 
            {(x,y). xy  yq  x < y in ys'  y < x in xs''  y < x in ys }
             {(x,y). xy  yq  x < y in ys'  y < x in xs''   x < y in xs' }" (is "?S1  ?S2 = ?S1  ?S2'")
              proof -
                have "?S2 = ?S2'" apply(safe)
                proof (goal_cases)
                  case (2 a b)
                  from 2(5) have "~ b < a in xs'" by auto
                  with 2(6) show "False" by auto
                next
                  case (1 a b)
                  from 1(4) have "a  set xs'" "b  set xs'" 
                    using  before_in_setD1[where xs="xs''"]
                     before_in_setD2[where xs="xs''"] ss2 by auto
                  with not_before_in 1(5) have "(a < b in xs'  a = b)" by metis
                  with 1(1) show "a < b in xs'" by auto
                qed
                then show ?thesis by auto
              qed
           also have "  = 
            {(x,y). xy  yq  x < y in ys'  y < x in xs''  y < x in ys }
             {(x,y). xy  yq  x < y in ys'  ~ x < y in xs''   x < y in xs' }" (is "?S1  ?S2 = ?S1  ?S2'")
              proof -
                have "?S2 = ?S2'" apply(safe)
                proof (goal_cases)
                  case (1 a b)
                  from 1(4) have "~ a < b in xs''" by auto
                  with 1(6) show "False" by auto
                next
                  case (2 a b)
                  from 2(5) have "a  set xs''" "b  set xs''" 
                    using  before_in_setD1[where xs="xs'"]
                     before_in_setD2[where xs="xs'"] ss2 by auto
                  with not_before_in 2(4) have "(b < a in xs''  a = b)" by metis
                  with 2(1) show "b < a in xs''" by auto
                qed
                then show ?thesis by auto
              qed
           also have "  = 
              {(x,y). xy  yq  x < y in ys'  y < x in xs''  y < x in ys }
               {}"
                using x_stays_before_y_if_y_not_moved_to_front[where xs="xs'" and q="q"] 
                    before_in_setD1[where xs="xs'"] before_in_setD2[where xs="xs'"]  by (auto simp: queryinlist) 
           also have "  = 
              {(x,y). xy  x=q  yq  x < y in ys'  y < x in xs''  y < x in ys }"
                apply(simp only: ya) using swapped_by_mtf2[where xs="ys" and q="q" and n="(length ys)"]  dys
                  before_in_setD1[where xs="ys"] before_in_setD2[where xs="ys"] by (auto simp: queryinlist) 
          also have "   
            {(x,y). x=q  yq  q < y in ys'  y < q in xs''}" by force
          also have " = 
            {(x,y). x=q  yq  q < y in ys'  y < q in xs''  y  set xs''}" 
              using before_in_setD1 by metis
          also have "  = 
            {(x,y). x=q  yq  q < y in ys'  index xs'' y < index xs'' q  q  set xs''  y  set xs''}" unfolding before_in_def by auto 
          also have "  = 
            {(x,y). x=q  yq  q < y in ys'  index xs'' y < index xs' q - (free_A ! n)  q  set xs''  y  set xs''}"
              using mtf2_q_after[where A="xs'" and q="q"] by force
          also have "   
            {(x,y). x=q  yq  index xs' y < index xs' q - (free_A ! n)  y  set xs''}" 
              using mtf2_backwards_effect4'[where xs="xs'" and q="q" and n="(free_A ! n)", simplified ]
              by auto
          also have " 
            {(x,y). x=q  yq  index xs' y < k'}" 
              using mtf2_q_after[where A="xs'" and q="q"] by auto

          finally have subsa: "(Inv ys' xs'')-(Inv ys xs')
               {(x,y). x=q  yq  index xs' y < k'}" .
 
          have k'xs': "k' < length xs''" unfolding whatisk'
            apply(rule index_less) by (auto simp: queryinlist) 
          then have k'xs': "k' < length xs'" by auto

          have "{(x,y). x=q  index xs' y < k'}
               {(x,y). x=q   index xs' y < length xs'}" using k'xs' by auto
          also have " = {(x,y). x=q   y  set xs'}" 
              using index_less_size_conv by fast
          finally have "{(x,y). x=q  index xs' y < k'}  {(x,y). x=q  y  set xs'}" .
          then have finia2: "finite {(x,y). x=q  index xs' y < k'}"
            apply(rule finite_subset) by(simp)

          have lulae: "{(a,b). a=q  index xs' b < k'}
              = {(q,b)|b.  index xs' b < k'}" by auto

          have k'b: "k' < length b" using whatisk' by (auto simp: queryinlist) 
          have asdasd: "{(α,β). α=q  βq  index xs' β < k'} 
            = {(α,β). α=q  βq  index xs' β < k'   (index init β) < length b }"
                    proof (auto, goal_cases)
                      case (1 b)
                      from 1(2) have "index xs' b < index xs' (q)" by auto
                      also have " < length xs'" by (auto simp: queryinlist) 
                      finally have "b  set xs'" using index_less_size_conv by metis
                      then show ?case using setinit by auto
                    qed
            
         { fix β
           have "βq   (index init β)(index init q)"
            using queryinlist by auto
         } note ij=this
         have subsa2: "{(α,β). α=q  βq  index xs' β < k'}  
            {(α,β). α=q  index xs' β < k'}" by auto
          then have finia: "finite {(x,y). x=q  yq  index xs' y < k'}"
            apply(rule finite_subset) using finia2 by auto

          have E0: "A = ((x,y)(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto
          also have E1: "  ((x,y){(a,b). a=q  bq  index xs' b < k'}. (if b'!(index init y) then 2::real else 1))"
              unfolding A_def apply(rule sum_mono2[OF finia subsa]) by auto
          also have " = ((x,y){(α,β). α=q  βq  index xs' β < k'
                             (index init β) < length b }. (if b'!(index init y) then 2::real else 1))"
                          using asdasd  by auto
          also have " = ((x,y){(α,β). α=q  βq  index xs' β < k' 
                            (index init β) < length b }. (if b!(index init y) then 2::real else 1))"
          proof (rule sum.cong, goal_cases)
             case (2 z)
             then obtain α β where zab: "z=(α, β)" and "α = q" and diff: "β  q" and "index xs' β < k'" and i: "index init β < length b" by auto
             from diff ij have "index init β  index init q" by auto
             with flip_other qsfst i have "b' ! index init β =  b ! index init β" unfolding b'_def  by auto
             with zab show ?case by(auto simp add:  split_def)
          qed simp
          also have E1a: " = ((x,y){(a,b). a=q  bq  index xs' b < k'}. (if b!(index init y) then 2::real else 1))"
                          using asdasd  by auto
          also have "  ((x,y){(a,b). a=q  index xs' b < k'}. (if b!(index init y) then 2::real else 1))"
              apply(rule sum_mono2[OF finia2 subsa2]) by auto
          also have E2: " = ((x,y){(q,b)|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))" 
              by (simp only: lulae[symmetric])
          finally have aa: "A  ((x,y){(q,b)|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))" .

          have sameset: "{y. index xs' y < k'} = {xs'!i | i. i < k'}" 
            proof (safe, goal_cases)
              case (1 z)
              show ?case
                proof 
                from 1(1) have "index xs' z < index (swaps (paid_A ! n) (s_A n)) (q)"
                  by auto
                also have " < length xs'" using index_less_size_conv by (auto simp: queryinlist) 
                finally have "index xs' z  < length xs'" .
                then have zset: "z  set xs'" using index_less_size_conv by metis
                have f1: "xs' ! (index xs' z) = z"
                  apply(rule nth_index) using zset by auto
                show "z = xs' ! (index xs' z)  (index xs' z) < k'"
                using f1 1(1)  by auto
              qed
            next
              case (2 k i)
              from 2(1) have "i < index (swaps (paid_A ! n) (s_A n)) (q)"
                by auto
              also have " < length xs'" using index_less_size_conv by (auto simp: queryinlist) 
              finally have iset: "i < length xs'" .
              have "index xs' (xs' ! i) = i" apply(rule index_nth_id)
                using iset by(auto)
              with 2 show ?case by auto
            qed
           
          have aaa23: "inj_on (λi. xs'!i) {i. i < k'}"
            apply(rule inj_on_nth)
              apply(simp)
              apply(simp) proof (safe, goal_cases)
                case (1 i)
                then have "i < index xs' (q)" by auto
                also have " < length xs'" using index_less_size_conv by (auto simp: queryinlist) 
                also have " = length init" by auto
                finally show " i < length init" .
              qed


          have aa3: "{xs'!i | i. i < k'} = (λi. xs'!i) ` {i. i < k'}" by auto
          have aa4: "{(q,b)|b. index xs' b < k'} = (λb. (q,b)) ` {b. index xs' b < k'}" by auto
             

          have unbelievable: "{i::nat. i < k'} = {..<k'}" by auto

          have aadad: "inj_on (λb. (q,b)) {b. index xs' b < k'}" 
            unfolding inj_on_def by(simp)

          have "((x,y){(q,b)|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
                = (y{y. index xs' y < k'}. (if b!(index init y) then 2::real else 1))"
                proof -
                  have "((x,y){(q,b)|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
                    = ((x,y) (λb. (q,b)) ` {b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))" using aa4 by simp
                  also have " = (z (λb. (q,b)) ` {b. index xs' b < k'}. (if b!(index init (snd z)) then 2::real else 1))" by (simp add: split_def)
                  also have " = (z{b. index xs' b < k'}. (if b!(index init (snd ((λb. (q,b)) z))) then 2::real else 1))"
                      apply(simp only: sum.reindex[OF aadad]) by auto  
                  also have " = (y{y. index xs' y < k'}. (if b!(index init y) then 2::real else 1))" by auto
                  finally show ?thesis .
                qed
          also have " = (y{xs'!i | i. i < k'}. (if b!(index init y) then 2::real else 1))" using sameset by auto
          also have " = (y(λi. xs'!i) ` {i. i < k'}. (if b!(index init y) then 2::real else 1))" using aa3 by simp
          also have " = (y{i::nat. i < k'}. (if b!(index init (xs'!y)) then 2::real else 1))" 
                using sum.reindex[OF aaa23] by simp
          also have E3: " = (j::nat<k'. (if b!(index init (xs'!j)) then 2::real else 1))" 
                  using unbelievable by auto
          finally have bb: "((x,y){(q,b)|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
              = (j<k'. (if b!(index init (xs'!j)) then 2::real else 1))" .
 
          have "A  (j<k'. (if b!(index init (xs'!j)) then 2::real else 1))"
            using aa bb by linarith

     
          then show "A
               (if b!(index init q) then k-k' else (j<k'. (if b!(index init (xs'!j)) then 2::real else 1)))"
              using False by auto   

        next
          case True
 
          then have samesame: "ys' = ys" unfolding ys'_def step_def by auto (* BIT does nothing *)

          have setxsbleibt: "set xs'' = set init" by auto
  
          have whatisk': "k' = index xs'' q" apply(simp)
              apply(rule mtf2_q_after[symmetric]) using queryinlist  by auto
                
          have "(Inv ys' xs'')-(Inv ys xs')
              = {(x,y). x < y in ys   y < x in xs''   ~ y < x in xs'}"
                    unfolding Inv_def using samesame by auto  
          also have 
            "   {(xs'!i,q)|i. i{k'..<k}}"
           apply(clarify)
           proof 
              fix a b
              assume 1: "a < b in ys"
                and 2: "b < a in xs''"
                and 3: "¬ b < a in xs'"
              then have anb: "a  b"
                  using no_before_inI by(force)
              have a: "a  set init"
                  and b: "b  set init"
                    using  before_in_setD1[OF 1] before_in_setD2[OF 1] by auto
              with anb 3 have 3: "a < b in xs'"                      
                      by (simp add: not_before_in) 
              note all= anb 1 2 3 a b 
              have bq: "b=q" apply(rule swapped_by_mtf2[where xs="xs'" and x=a])
               using queryinlist apply(simp_all add: all) 
               using all(4) apply(simp) 
               using all(3) apply(simp) done

              note mine=mtf2_backwards_effect3[THEN conjunct1]

              from bq have "q < a in xs''" using 2 by auto
              then have "(k' < index xs'' a  a  set xs'')"
                unfolding before_in_def
                  using  whatisk' by auto
              then have low : "k'  index xs' a"
                unfolding whatisk'
                 unfolding xs''_def  
                 apply(subst mtf2_q_after)
                   apply(simp)
                  using queryinlist apply(simp) 
                 apply(rule mine)
                    apply (simp add: queryinlist)
                   using bq b apply(simp)
                  apply(simp)
                 apply(simp del: xs'_def)
                 apply (metis "3" a before_in_def bq dp_xs'_init k'_def k_def max_0L mtf2_forward_beforeq nth_index whatisk' xs''_def)
                using a by(simp)(* 

                 unfolding xs'_def xs_def
                sledgehammer TODO: make this step readable  
by (metis "3" mtf2_q_after a before_in_def bq dp_xs'_init index_less_size_conv mtf2_forward_beforeq nth_index whatisk' xs''_def xs'_def xs_def)
 *)
              from bq have "a < q in xs'" using 3 by auto
              then have up: "(index xs' a < k )"
                unfolding before_in_def by auto

              from a have "a  set xs'" by simp
              then have aa: "a = xs'!index xs' a" using nth_index by simp 

              have inset: "index xs' a  {k'..<k}"
                using low up by fastforce

              from bq aa show "(a, b) = (xs' ! index xs' a, q)  index xs' a  {k'..<k}"
                using inset by simp 
            qed 
          finally have a: "(Inv ys' xs'')-(Inv ys xs')  {(xs'!i,q)|i. i{k'..<k}}" (is "?M  ?UB") .
 
          have card_of_UB: "card {(xs'!i,q)|i. i{k'..<k}} = k-k'" 
          proof -
            have e: "fst ` ?UB = (%i. xs' ! i) ` {k'..<k}" by force
            have "card ?UB = card (fst ` ?UB)"
                  apply(rule card_image[symmetric])
                      using inj_on_def by fastforce
          also
            have " = card ((%i. xs' ! i) ` {k'..<k})" 
              by (simp only: e)
          also
            have " = card {k'..<k}"
                  apply(rule card_image)
                  apply(rule inj_on_nth)
                    using k_inbounds by simp_all 
          also
            have " = k-k'" by auto
          finally
            show ?thesis .
          qed
 
          have flipit: "flip (index init q) b ! (index init q) =  (~ (b) ! (index init q))" apply(rule flip_itself)
            using queryinlist setinit by auto

           
          have q: "{x?UB. snd x=q} = ?UB" by auto

          have E0: "A = ((x,y)(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto
          also have E1: "  ((z,y)?UB. if flip (index init q) (b) ! (index init y) then 2::real else 1)" 
              unfolding b'_def apply(rule sum_mono2[OF _ a]) 
                by(simp_all add: split_def)
          also have " = ((z,y){x?UB. snd x=q}. if flip (index init q) (b) ! (index init y) then 2::real else 1)" by(simp only: q)
          also have " = (z{x?UB. snd x=q}. if flip (index init q) (b) ! (index init (snd z)) then 2::real else 1)" by(simp add: split_def)
          also have " = (z{x?UB. snd x=q}. if flip (index init q) (b) ! (index init q) then 2::real else 1)" by simp
          also have E2: " = (z?UB. if flip (index init q) (b) ! (index init q) then 2::real else 1)" by(simp only: q)
          also have E3: " = (y?UB. 1)" using flipit True by simp
          also have E4: " = k-k'"
              by(simp only: real_of_card[symmetric] card_of_UB)  
          finally have result: "A   k-k'" .
          with True show ?thesis by auto
        qed


        show "((x,y)(Inv ys' xs''). (if b'!(index init y) then 2::real else 1)) - ((x,y)(Inv ys xs'). (if b!(index init y) then 2::real else 1))  ?ub2" 
                  unfolding ub_free_def teilen[unfolded Δ_def A_def B_def C_def] using BC_absch A_absch using True 
                    by auto
      qed 
      from paid_ub have kl: "Φ1 x  Φ0 x + ?paidUB" by auto
      from free_ub have kl2: "Φ2 x -  ?ub2  Φ1 x" using gis dis by auto

 
      have iub_free: "I + ?ub2 =  ub_free" by auto 

      from kl kl2 have "Φ2 x - Φ0 x  ?ub2 + ?paidUB" by auto

      then have "(cost x) + (Φ2 x) - (Φ0 x)  k + 1 + I + ?ub2 + ?paidUB" using ub_cost_BIT by auto
  
      then show ?case unfolding ub_free_def b_def by auto 
    qed   

text "Approximation of the Term for Free exchanges"

 
    have free_absch: "E(map_pmf (λx. (if (q)  set init then (if (fst (snd x))!(index init q) then k-k' 
                else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1))) else 0)) D)
           3/4 * k" (is "?EA  ?absche")
    proof (cases "(q)  set init")
      case False
       
      then have "?EA = 0" by auto 
      then show ?thesis by auto
    next
      case True


      note queryinlist=this

      have "k-k'  k" by auto
      have "k'  k" by auto
 

      text "Transformation of the first term" 

 

        have qsn: "{index init q}  {}  {0..<?l}" using setinit queryinlist by auto

        have "{l::bool list. length l = ?l  l!(index init q)}
          = {xs. Ball {(index init q)} ((!) xs)  (i{}. ¬ xs ! i)  length xs = ?l}" by auto
        then have "card {l::bool list. length l = ?l  l!(index init q)}
          = card {xs. Ball {index init q} ((!) xs)  (i{}. ¬ xs ! i)  length xs = length init} " by auto
        also have " = 2^(length init - card {index init q} - card {})" 
                  apply(subst card2[of "{(index init q)}" "{}" "?l"]) using qsn by auto
        finally have lulu: "card {l::bool list. length l = ?l  l!(index init q)} = 2^(?l-1)" by auto

        have "(x{l::bool list. length l = ?l  l!(index init q)}. real(k-k'))
            = (x{l::bool list. length l = ?l  l!(index init q)}. k-k')" by auto    
        also have " = (k-k')*2^(?l-1)" using lulu by simp
     
   finally have absch1stterm:  "(x{l::bool list. length l = ?l  l!(index init q)}. real(k-k'))
                              = real((k-k')*2^(?l-1))" .
 
      text "Transformation of the second term"       
 

        let ?S="{(xs'!j)|j. j<k'}"

        from queryinlist have "q  set (swaps (paid_A ! n) (s_A n))" by auto
        then have "index (swaps (paid_A ! n) (s_A n)) q < length xs'" by auto
        then have k'inbound: "k' < length xs'" by auto 
        
        { fix x
          have a: "{..<k'} = {j. j<k'}" by auto
          have b: "?S = ((%j. xs'!j) ` {j. j<k'})" by auto

          have "(j<k'. (λt. (if x!(index init t) then 2::real else 1)) (xs'!j))
            = sum ((λt. (if x!(index init t) then 2::real else 1)) o (%j. xs'!j)) {..<k'}"
              by(auto)
          also have " = sum ((λt. (if x!(index init t) then 2::real else 1)) o (%j. xs'!j)) {j. j<k'}"
              by (simp only: a)
          also have " = sum (λt. (if x!(index init t) then 2::real else 1)) ((%j. xs'!j) ` {j. j<k'})"
              apply(rule sum.reindex[symmetric])
              apply(rule inj_on_nth)
                using k'inbound by(simp_all)
          finally have "(j<k'. (λt. (if x!(index init t) then 2::real else 1)) (xs'!j))                   
                  = (j?S. (λt. (if x!(index init t) then 2 else 1)) j)" using b by simp              
        } note reindex=this

        have identS: "?S = set (take k' xs')"
          proof -
              have "index (swaps (paid_A ! n) (s_A n)) (q)  length (swaps (paid_A ! n) (s_A n))"
                  by (rule index_le_size)
              then have kxs': "k'  length xs'" by simp
              have "?S = (!) xs' ` {0..<k'}" by force
              also have " = set (take k' xs')" apply(rule nth_image) by(rule kxs')
              finally show "?S = set (take k' xs')" .
          qed
        have distinctS: "distinct (take k' xs')" using distinct_take identS by simp
        have lengthS: "length (take k' xs') = k'" using length_take k'inbound by simp
        from distinct_card[OF distinctS] lengthS have "card (set (take k' xs')) = k'" by simp
        then have cardS: "card ?S = k'" using identS by simp
        
        have a: "?S  set xs'" using set_take_subset identS by metis
        then have Ssubso: "(index init) ` ?S  {0..<?l}" using setinit by auto
        from a have s_subst_init: "?S  set init" by auto
        
        note index_inj_on_S=subset_inj_on[OF inj_on_index[of "init"] s_subst_init]

        have l: "xs'!k = q" unfolding k_def apply(rule nth_index) using queryinlist by(auto)
        have "xs'!k  set (take k' xs')"
            apply(rule index_take) using l by simp
        then have requestnotinS: "(q)  ?S" using l identS by simp
        then have indexnotin: "index init q  (index init) ` ?S"
            using index_inj_on_S s_subst_init by auto
       

        have lua: "{l. length l = ?l  ~l!(index init q)}
            = {xs. (i{}. xs ! i)  (i{index init q}. ¬ xs ! i)  length xs = ?l}" by auto


        from k'inbound have k'inbound2: "Suc k'  length init" using Suc_le_eq by auto

        (* rewrite from sum over indices of the list 
            to sum over elements (thus indices of the bit vector) *)
        have "(x{l::bool list. length l = ?l  ~l!(index init q)}. (j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))
                     
                = (x{l. length l = ?l  ~l!(index init q)}. (j?S. (λt. (if x!(index init t) then 2 else 1)) j))"
                using reindex by auto
        
        (* rewrite to conform the syntax of  Expactation2or1 *)
        also
        have " = (x{xs. (i{}. xs ! i)  (i{index init q}. ¬ xs ! i)  length xs = ?l}. (j?S. (λt. (if x!(index init t) then 2 else 1)) j))" 
          using lua by auto   
        also
        have " = (x{xs. (i{}. xs ! i)  (i{index init q}. ¬ xs ! i)  length xs = ?l}. (j(index init) ` ?S. (λt. (if x!t then 2 else 1)) j))" 
        proof -
          { fix x
          have "(j?S. (λt. (if x!(index init t) then 2 else 1)) j)
              = (j(index init) ` ?S. (λt. (if x!t then 2 else 1)) j)"
                apply(simp only: sum.reindex[OF index_inj_on_S, where g="(%j. if x ! j then 2 else 1)"])
                by(simp) 
          } note a=this
          show ?thesis by(simp only: a)
        qed

        (* use  Expactation2or1, and solve all the conditions *)
        also
        have " = 3 / 2 * real (card ?S) * 2 ^ (?l - card {} - card {q})"
          apply(subst Expactation2or1)
            apply(simp)
            apply(simp)
            apply(simp)
            apply(simp only: card_image index_inj_on_S cardS ) apply(simp add: k'inbound2 del: k'_def)
            using indexnotin apply(simp add: )
            apply(simp)
            using Ssubso queryinlist apply(simp)
            apply(simp only: card_image[OF index_inj_on_S]) by simp 
        finally have "(x{l. length l = ?l  ¬ l ! (index init q)}. j<k'. if x ! (index init (xs' ! j)) then 2 else 1)
        = 3 / 2 *  real (card ?S) * 2 ^ (?l - card {} - card {q}) " .

        (* insert the cardinality of S*)
        also
        have "3 / 2 *  real (card ?S) *  2 ^ (?l - card {} - card {q}) = (3/2) * (real (k')) *  2 ^ (?l - 1)" using cardS by auto

        finally have absch2ndterm: " (x{l. length l = ?l   ¬ l ! (index init q)}.
                              j<k'. if x !(index init (xs' ! j)) then 2 else 1) =
                              3 / 2 * real (k') * 2 ^ (?l - 1) " .
 

      text "Equational transformations to the goal" 

      have cardonebitset: "card {l::bool list. length l = ?l  l!(index init q)} = 2^(?l-1)" using lulu by auto

      have splitie: "{l::bool list. length l = ?l}
            = {l::bool list. length l = ?l  l!(index init q)}  {l::bool list. length l = ?l  ~l!(index init q)}"
            by auto
      have interempty: "{l::bool list. length l = ?l  l!(index init q)}  {l::bool list. length l = ?l  ~l!(index init q)}
            = {}" by auto
      have fa: "finite {l::bool list. length l = ?l  l!(index init q)}" using bitstrings_finite by auto
      have fb: "finite {l::bool list. length l = ?l  ~l!(index init q)}" using bitstrings_finite by auto

      { fix f :: "bool list  real"
        have "(x{l::bool list. length l = ?l}. f x)
        = (x{l::bool list. length l = ?l  l!(index init q)}  {l::bool list. length l = ?l  ~l!(index init q)}. f x)" by(simp only: splitie)
        also have "
            =     (x{l::bool list. length l = ?l  l!(index init q)}. f x)
                              + (x{l::bool list. length l = ?l  ~l!(index init q)}. f x)
                              - (x{l::bool list. length l = ?l  l!(index init q)}  {l::bool list. length l = ?l  ~l!(index init q)}. f x)"
        using sum_Un[OF fa fb, of "f"] by simp
        also have " = (x{l::bool list. length l = ?l  l!(index init q)}. f x)
                              + (x{l::bool list. length l = ?l  ~l!(index init q)}. f x)" by(simp add: interempty)
        finally have "sum f {l. length l = length init} =
  sum f {l. length l = length init  l ! (index init q)} + sum f {l. length l = length init  ¬ l ! (index init q)}" .
      } note darfstsplitten=this



      have E1: "E(map_pmf (λx. (if (fst (snd x))!(index init q) then real(k-k') else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))) D)
          = E(map_pmf (λx. (if x!(index init q) then real(k-k') else (j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) (map_pmf (fst  snd) D))"
          proof -
            have triv: "x. (fst  snd) x = fst (snd x)" by simp 
            have "E((map_pmf (λx. (if (fst (snd x))!(index init q) then real(k-k') else (j<k'. (if (fst (snd x))!index init (xs'!j) then 2::real else 1))))) D)
                = E(map_pmf (λx. ((λy. (if y!(index init q) then real(k-k') else (j<k'. (if y!index init (xs'!j) then 2::real else 1))))  (fst  snd)) x) D)"
                apply(auto simp: comp_assoc) by (simp only: triv)
            also have " = E((map_pmf (λx. (if x!(index init q) then real(k-k') else (j<k'. (if x!index init (xs'!j) then 2::real else 1))))  (map_pmf (fst  snd))) D)" 
                using map_pmf_compose by metis
            also have " = E(map_pmf (λx. (if x!(index init q) then real(k-k') else (j<k'. (if x!index init (xs'!j) then 2::real else 1)))) (map_pmf (fst  snd) D))" by auto
            finally show ?thesis .
          qed
      also
      have E2:  " = E(map_pmf (λx. (if x!(index init q) then real(k-k') else (j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) (bv ?l))"
          using config_n_bv[of init _] by auto
      also
      let ?insf="(λx. (if x!(index init q) then k-k' else (j<k'. (if x!(index init (xs'!j)) then 2::real else 1))))"
      have E3: " = (x(set_pmf (bv ?l)). (?insf x) * pmf (bv ?l) x)"
        by (subst E_finite_sum_fun) (auto simp: bv_finite mult_ac)
      also
      have " = (x{l::bool list. length l = ?l}. (?insf x) * pmf (bv ?l) x)"
      using bv_set by auto
      also
      have E4: " = (x{l::bool list. length l = ?l}. (?insf x) * (1/2)^?l)"
        by (simp add: list_pmf)
      also
      have " = (x{l::bool list. length l = ?l}. (?insf x)) * ((1/2)^?l)"
      by(simp only: sum_distrib_right[where r="(1/2)^?l"])
      also
      have E5: " = ((1/2)^?l) *(x{l::bool list. length l = ?l}. (?insf x))"
      by(auto)
      also
      have E6: " = ((1/2)^?l) * (  (x{l::bool list. length l = ?l  l!(index init q)}. ?insf x)
                              + (x{l::bool list. length l = ?l  ~l!(index init q)}. ?insf x)
                             )" using darfstsplitten by auto
      also
      have E7: " = ((1/2)^?l) * (  (x{l::bool list. length l = ?l  l!(index init q)}. ((λx. real(k-k'))) x)
                              + (x{l::bool list. length l = ?l  ~l!(index init q)}. ((λx. (j<k'. (if x!index init (xs'!j) then 2::real else 1)))) x)
                             )" by auto
      finally have "E(map_pmf (λx. (if (fst (snd x))!(index init q) then real(k-k') else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))) D)
            = ((1/2)^?l) * (  (x{l::bool list. length l = ?l  l!(index init q)}. ((λx. real(k-k'))) x)
                              + (x{l::bool list. length l = ?l  ~l!(index init q)}. ((λx. (j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) x)
                             )" .
      also
      have " = ((1/2)^?l) * (  (x{l::bool list. length l = ?l  l!(index init q)}. real(k-k'))
                              + (3/2)*(real (k'))*2^(?l-1)
                             )" by(simp only: absch2ndterm)
      also
      have E8: " = ((1/2)^?l) * ( real((k-k')*2^(?l-1)) + (3/2)*(real (k'))*2^(?l-1))"
          by(simp only: absch1stterm)
      (* from here it is only arithmetic ... *)
      also have " = ((1/2)^?l) * ( (  (k-k') + (k')*(3/2)  ) * 2^(?l-1) )" apply(simp only: distrib_right) by simp
      also have " = ((1/2)^?l) * 2^(?l-1) * (   (k-k') + (k')*(3/2)    )" by simp
      also have " = (((1::real)/2)^(Suc l')) * 2^(l') * (   real(k-k') + (k')*(3/2)    )"
      using lSuc by auto (* REFACTOR: the only place where I use lSuc , can I avoid it? 
                yes, if ?l=0 then k=k'<?l impossible, perhaps I can insert that
                  somehow ? 
              *)
      also have E9: " = (1/2) *   (   real(k-k') + (k')*(3/2)    )"
      proof - 
        have "((1::real)/2)^l' * 2^l'  = ((1::real)/2 * 2)^l' " by(rule power_mult_distrib[symmetric])
        also have "...   = 1" by auto
        finally have "(((1::real)/2)^(Suc l'))* 2^l'=(1/2)" by auto
        then show ?thesis by auto
      qed      
      also have E10: "  (1/2) * (  (3/2)*(k-k') + (k')*(3/2)  )" by auto (* and one inequality *)
      also have " = (1/2) * (  (3/2)*(k-k'+(k'))  )" by auto
      also have " = (1/2) * (  (3/2)*(k)  )" by auto
      also have E11: " = (3/4)*(k )" by auto
      finally show "E(map_pmf (λx. (if q  set init then (if (fst (snd x))!(index init q) then real( k-k' ) else (j<k'. (if (fst (snd x))!index init (xs'!j) then 2::real else 1))) else 0 )) D)
           3/4 * k " using True by simp    
 
    qed (* free_absch *)
 


text "Transformation of the Term for Paid Exchanges"
 
    have paid_absch: "E(map_pmf (λx. (i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1) )) D) = 3/2 * (length (paid_A!n))"
    proof - 

      {
        fix i
        assume inbound: "(index init i) < length init"
        have "map_pmf (λxx. if fst (snd xx) ! (index init i) then 2::real else 1) D =
                  bind_pmf (map_pmf (fst  snd) D) (λb. return_pmf (if b! index init i then 2::real else 1))"
                            unfolding map_pmf_def by(simp add: bind_assoc_pmf bind_return_pmf)
        also have " = bind_pmf (bv (length init)) (λb. return_pmf (if b! index init i then 2::real else 1))"
                    using config_n_bv[of init "take n qs"] by simp 
        also have " = map_pmf (λyy. (if yy then 2 else 1)) ( map_pmf (λy. y!(index init i)) (bv (length init)))"
              by (simp add: map_pmf_def bind_return_pmf bind_assoc_pmf)    
        also have " = map_pmf (λyy. (if yy then 2 else 1)) (bernoulli_pmf (5 / 10))"
               by (auto simp add:  bv_comp_bernoulli[OF inbound]) 
        finally have "map_pmf (λxx. if fst (snd xx) ! (index init i) then 2::real else 1) D =
                      map_pmf (λyy. if yy then 2::real else 1) (bernoulli_pmf (5 / 10)) " .
      } note umform = this
    
    
      have "E(map_pmf (λx. (i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D) = 
          (i<(length (paid_A!n)). E(map_pmf ((λxx. (if (fst (snd xx))!(gebub n i) then 2::real else 1))) D))"
          apply(subst E_linear_sum2)
            using finite_config_BIT[OF dist_init] by(simp_all)
      also have " =  (i<(length (paid_A!n)). E(map_pmf (λy. if y then 2::real else 1) (bernoulli_pmf (5 / 10))))" using umform gebub_def gebub_inBound[OF 31] by simp
      also have " =  3/2 * (length (paid_A!n))" by(simp add: E_bernoulli)
      finally show "E(map_pmf (λx. (i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D) = 3/2 * (length (paid_A!n))" .
    qed
    
text "Combine the Results"
 
    (* cost of A *)
    have costA_absch: "k+(length (paid_A!n)) + 1 = t_A n" unfolding k_def q_def c_A_def p_A_def t_A_def by (auto)

    (* combine *)
    let  ?yo= "(λx. (cost x) + (Φ2 x) - (Φ0 x))"
    let ?yo2=" (λx. (k + 1) + (if (q)set init then (if (fst (snd x))!(index init q) then k-k' 
                                              else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)) ) else 0)
                                                  +(i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2 else 1)))"
 
    have E0: "t_BIT n + Phi(n+1) - Phi n = E (map_pmf ?yo D) "
      using inEreinziehn by auto
    also have "  E(map_pmf ?yo2 D)"
           apply(rule E_mono2) unfolding D_def
            apply(fact finite_config_BIT[OF dist_init])
            apply(fact ub_cost[unfolded D_def])
            done

    also have E2: " = E(map_pmf (λx. k + 1::real) D)
            + (E(map_pmf (λx. (if (q)set init then (if (fst (snd x))!(index init q) then real(k-k') else (j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))else 0)) D)
            + E(map_pmf (λx. (i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D))"
             unfolding D_def  apply(simp only: E_linear_plus2[OF finite_config_BIT[OF dist_init]]) by(auto simp: add.assoc)
 
    also have E3: "   k + 1 + (3/4 * (real (k)) + (3/2 * real (length (paid_A!n))))" using paid_absch free_absch by auto

    also have " = k + (3/4 * (real k)) + 1  + 3/2 *(length (paid_A!n)) " by auto  (* arithmetic! *)
    also have " = (1+3/4) * (real k) + 1  + 3/2 *(length (paid_A!n)) " by auto  (* arithmetic! *)
    also have E4: " = 7/4*(real k) + 3/2 *(length (paid_A!n)) + 1 " by auto (* arithmetic! *)
    also have "  7/4*(real k) + 7/4 *(length (paid_A!n)) + 1" by auto (* arithmetic! *)
    also have E5:" = 7/4*(k+(length (paid_A!n))) + 1 " by auto
    also have E6:" = 7/4*(t_A n - (1::real)) + 1" using costA_absch by auto
    also have " = 7/4*(t_A n) - 7/4 + 1" by algebra
    also have E7: " = 7/4*(t_A n)- 3/4" by auto
    finally  show "t_BIT n + Phi(n+1) - Phi n  (7 / 4) * t_A n - 3/4" .
  qed
  then show "t_BIT n + Phi(n + 1) - Phi n  (7 / 4) * t_A n - 3/4" .
qed

subsubsection "Lift the Result to the Whole Request List"

 
lemma T_BIT_absch_le: assumes nqs: "n  length qs"
  shows "T_BIT n  (7 / 4) * T_A n - 3/4*n"
unfolding T_BIT_def T_A_def
proof - 
  from potential2[of "Phi", OF phi0 phi_pos myub] nqs have
      "sum t_BIT {..<n}  (i<n. 7 / 4 *   (t_A i) - 3 / 4)" by auto
  also have " = (i<n. 7 / 4 * real_of_int (t_A i)) - (i<n. (3/4))" by (rule sum_subtractf)
  also have " = (i<n. 7 / 4 * real_of_int (t_A i)) - (3/4)*(i<n. 1)" by simp
  also have " = (i<n. (7 / 4) * real_of_int (t_A i)) - (3/4)*n" by simp
  also have " =  (7 / 4) * (i<n. real_of_int (t_A i))  - (3/4)*n" by (simp add: sum_distrib_left)
  also have " = (7 / 4) * real_of_int (i<n.(t_A i))  - (3/4)*n" by auto
  finally show "sum t_BIT {..<n}  7 / 4 * real_of_int (sum t_A {..<n})  - (3/4)*n" by auto
qed 



lemma T_BIT_absch: assumes nqs: "n  length qs"
  shows "T_BIT n  (7 / 4) * T_A' n - 3/4*n"
using nqs T_BIT_absch_le[of n] T_A_A'_leq[of n] by auto

lemma T_A_nneg: "0  T_A n"
by(auto simp add: sum_nonneg T_A_def t_A_def c_A_def p_A_def)

 

lemma T_BIT_eq: "T_BIT (length qs) = T_on_rand BIT init qs"
unfolding T_BIT_def T_on_rand_as_sum using t_BIT_def  by auto


corollary T_BIT_competitive: assumes "n  length qs" and "init  []" and "i<n. qs!i  set init"
shows "T_BIT n  ((7 / 4) - 3/(4 * size init)) * T_A' n"
proof cases
  assume 0: "real_of_int(T_A' n)  n * (size init)"
  then have 1: "3/4*real_of_int(T_A' n)  3/4*(n * (size init))" by auto
  have "T_BIT n  (7 / 4) * T_A' n - 3/4*n" using T_BIT_absch[OF assms(1)] by auto
  also have " = ((7 / 4) * real_of_int(T_A' n)) - (3/4*(n * size init)) / size init"
    using assms(2) by simp
  also have "  ((7 / 4) * real_of_int(T_A' n)) - 3/4*T_A' n / size init"
    by(rule diff_left_mono[OF  divide_right_mono[OF 1]]) simp
  also have " = ((7 / 4) - 3/4 / size init) * T_A' n" by algebra
  also have " = ((7 / 4) - 3/(4 * size init)) * T_A' n" by simp
  finally show ?thesis .
next
  assume 0: "¬ real_of_int(T_A' n)  n * (size init)"

  have T_A'_nneg: "0  T_A' n" using T_A_nneg[of n] T_A_A'_leq[of n] assms(1) by auto

  have "2 - 1 / size init  1" using assms(2)
    by (auto simp add: field_simps neq_Nil_conv)
  have " T_BIT n   n * size init" using T_BIT_ub[OF assms(3)] by linarith
  also have " < real_of_int(T_A' n)" using 0 by linarith
  also have "  ((7 / 4) - 3/4 / size init) * T_A' n" using assms(2) T_A'_nneg
    by(auto simp add: mult_le_cancel_right1 field_simps neq_Nil_conv)
  finally show ?thesis by simp
qed


lemma t_A'_t: "n < length qs  t_A' n = int (t (s_A' n) (qs!n) (acts ! n))"
by (simp add: t_A'_def t_def c_A'_def p_A'_def paid_A'_def len_acts split: prod.split)

lemma T_A'_eq_lem: "(i=0..<length qs. t_A' i) =
  T (s_A' 0) (drop 0 qs) (drop 0 acts)"
proof(induction rule: zero_induct[of _ "size qs"])
  case 1 thus ?case by (simp add: len_acts)
next
  case (2 n)
  show ?case
  proof cases
    assume "n < length qs"
    thus ?case using 2
    by(simp add: Cons_nth_drop_Suc[symmetric,where i=n] len_acts sum.atLeast_Suc_lessThan
      t_A'_t free_A_def paid_A'_def)
  next
    assume "¬ n < length qs" thus ?case by (simp add: len_acts)
  qed
qed

lemma T_A'_eq: "T_A' (length qs) = T init qs acts"
using T_A'_eq_lem by(simp add: T_A'_def atLeast0LessThan)

corollary BIT_competitive3: "init  []  i<length qs. qs!i  set init 
  T_BIT (length qs)  ( (7/4) - 3 / (4 * length init)) * T init qs acts"
using order.refl T_BIT_competitive[of "length qs"] T_A'_eq by (simp add: of_int_of_nat_eq)

corollary BIT_competitive2: "init  []  i<length qs. qs!i  set init 
  T_on_rand BIT init qs  ( (7/4) - 3 / (4 * length init)) * T init qs acts"
using BIT_competitive3 T_BIT_eq by auto

corollary BIT_absch_le: "init  [] 
  T_on_rand BIT init qs  (7 / 4) * (T init qs acts) - 3/4 * length qs"
using T_BIT_absch[of "length qs", unfolded T_A'_eq T_BIT_eq] by auto
 
end
 

subsubsection "Generalize Competitivness of BIT"
 

lemma setdi: "set xs = {0..<length xs}  distinct xs"
apply(rule card_distinct) by auto


theorem compet_BIT: assumes "init  []" "distinct init" "set qs  set init"  
shows "T_on_rand BIT init qs  ( (7/4) - 3 / (4 * length init)) * T_opt init qs"
proof-
  from assms(3) have 1: "i < length qs. qs!i  set init" by auto
  { fix acts :: "answer list" 
    assume len: "length acts = length qs"
    interpret BIT_Off acts qs init proof qed (auto simp: assms(2) len)
    from BIT_competitive2[OF assms(1) 1] assms(1)
    have "T_on_rand BIT init qs / ( (7/4) - 3 / (4 * length init))  real(T init qs acts)"
      by(simp add: field_simps length_greater_0_conv[symmetric]
        del: length_greater_0_conv) }
    hence "T_on_rand BIT init qs / ( (7/4) - 3 / (4 * length init))  T_opt init qs"
      apply(simp add: T_opt_def Inf_nat_def)
      apply(rule LeastI2_wellorder)
      using length_replicate[of "length qs" undefined] apply fastforce
      apply auto
      done
  thus ?thesis using assms by(simp add: field_simps
    length_greater_0_conv[symmetric] del: length_greater_0_conv)
qed
 
theorem compet_BIT4: assumes "init  []" "distinct init"   
shows "T_on_rand BIT init qs  7/4 * T_opt init qs"
proof- 
  { fix acts :: "answer list" 
    assume len: "length acts = length qs"
    interpret BIT_Off acts qs init proof qed (auto simp: assms(2) len)
    from BIT_absch_le[OF assms(1)] assms(1)
    have "(T_on_rand BIT init qs + 3 / 4 * length qs)/ (7/4)  real(T init qs acts)"
      by(simp add: field_simps length_greater_0_conv[symmetric]
        del: length_greater_0_conv) }
    hence "(T_on_rand BIT init qs + 3 / 4 * length qs)/ (7/4)  T_opt init qs"
      apply(simp add: T_opt_def Inf_nat_def)
      apply(rule LeastI2_wellorder)
      using length_replicate[of "length qs" undefined] apply fastforce
      apply auto
      done
  thus ?thesis by(simp add: field_simps
    length_greater_0_conv[symmetric] del: length_greater_0_conv)
qed
 
theorem compet_BIT_2:
 "compet_rand BIT (7/4) {init. init  []  distinct init}"
unfolding compet_rand_def
proof 
  fix init
  assume "init  {init. init  []  distinct init }"
  then have ne: "init  []" and  a: "distinct init" by auto
  {
    fix qs
    assume "init  []" and a: "distinct init"
    then have "T_on_rand BIT init qs  7/4 * T_opt init qs"
      using compet_BIT4[of init qs] by simp
  }
  with a ne  show "b0. qs. static init qs  T_on_rand BIT init qs    (7 / 4) * (T_opt init qs) + b"
    by auto
qed
  
end

Theory Partial_Cost_Model

(*  Title:       The Partial Cost Model of the List Update Problem
    Author:      Max Haslbeck
*)

section "Partial cost model"

theory Partial_Cost_Model
imports Move_to_Front
begin

definition tp :: "'a state  'a  answer  nat" where
"tp s q a = (let (mf,sws) = a in index (swaps sws s) q + size sws)"

notation (latex) tp ("latex‹$t^{*}$›")

lemma tpt: "tp s q a + 1 = t s q a" unfolding tp_def t_def by(simp add: split_def)

interpretation On_Off step tp static .
                 
abbreviation "Tp == T"
abbreviation "Tp_opt == T_opt" 
abbreviation "Tp_on == T_on"
abbreviation "Tp_on_rand' == T_on_rand'"
abbreviation "Tp_on_n == T_on_n"
abbreviation "Tp_on_rand == T_on_rand"
abbreviation "Tp_on_rand_n == T_on_rand_n"
abbreviation "configp == config "
abbreviation "competp == compet"
                                            


end

Theory RExp_Var

(*  Title:       Enable Checking of Equivalence of Regular Expressions with Variables
    Author:      Max Haslbeck
    Reference:   http://www4.in.tum.de/lehre/vorlesungen/theo/SS10/vorlesung.shtml p.96ff
*)
section ‹Equivalence of Regular Expression with Variables›

theory RExp_Var
imports "Regular-Sets.Equivalence_Checking"
begin

(* even Atoms → normal Atoms
    odd Atoms → Variables *)
fun castdown :: "nat rexp  nat rexp" where
  "castdown Zero = Zero"
| "castdown One = One"
| "castdown (Plus a b) = Plus (castdown a) (castdown b)"
| "castdown (Times a b) = Times (castdown a) (castdown b)"
| "castdown (Star a) = Star (castdown a)"
| "castdown (Atom x) = (Atom (x div 2))"

fun castup :: "nat rexp  nat rexp" where
  "castup Zero = Zero"
| "castup One = One"
| "castup (Plus a b) = Plus (castup a) (castup b)"
| "castup (Times a b) = Times (castup a) (castup b)"
| "castup (Star a) = Star (castup a)"
| "castup (Atom x) = Atom (2*x)"

lemma "castdown (castup r) = r"
apply(induct r) by(auto)


fun substvar :: "nat  (nat  ((nat rexp) option))  nat rexp" where
  "substvar i σ = (case σ i of Some x  x
                              | None  Atom (2*i+1))"

fun w2rexp :: "nat list  nat rexp" where
  "w2rexp [] = One"
| "w2rexp (a#as) = Times (Atom a) (w2rexp as)"

lemma "lang (w2rexp as) = { as }"
apply(induct as)
  apply(simp)
  by(simp add: conc_def)



fun subst :: "nat rexp  (nat  nat rexp option)  nat rexp" where
  "subst Zero _ = Zero"
| "subst One _ = One"
| "subst (Atom i) σ = (if i mod 2 = 0 then Atom i else substvar (i div 2) σ)"
| "subst (Plus a b) σ = Plus (subst a σ) (subst b σ)"
| "subst (Times a b) σ = Times (subst a σ) (subst b σ)"
| "subst (Star a) σ = Star (subst a σ)"


lemma subst_w2rexp: "lang (subst (w2rexp (xs @ ys)) σ) = lang (subst (w2rexp xs) σ) @@ lang (subst (w2rexp ys) σ)"
proof(induct xs)
  case (Cons x xs)
  have "lang (subst (w2rexp ((x # xs) @ ys)) σ)
        = lang (subst (Times (Atom x) (w2rexp (xs @ ys))) σ)" by simp
  also have " = lang (Times (subst (Atom x) σ) (subst (w2rexp (xs @ ys)) σ))" by simp
  also have " = lang (subst (Atom x) σ) @@ (lang (subst (w2rexp (xs @ ys)) σ))" by simp
  also have " = lang (subst (Atom x) σ) @@ ( lang (subst (w2rexp xs) σ) @@ lang (subst (w2rexp ys) σ) )" by(simp only: Cons)
  also have " = lang (Times (subst (Atom x) σ) (subst (w2rexp xs) σ)) @@ lang (subst (w2rexp ys) σ) " 
            apply(simp del: subst.simps) by(rule conc_assoc[symmetric])
  also have " = lang (subst (Times (Atom x) (w2rexp xs)) σ) @@ lang (subst (w2rexp ys) σ)" by simp
  also have " = lang (subst (w2rexp (x # xs)) σ) @@ lang (subst (w2rexp ys) σ)" by simp
  finally show ?case .
qed simp

fun substW :: "nat list  (nat  nat rexp option)  nat rexp" where
  "substW as σ = subst (w2rexp as) σ"

fun substL :: "nat lang  (nat  nat rexp option)  nat rexp set" where
  "substL S σ = {substW a σ|a. a  S}"

fun L :: "nat rexp set  nat lang" where
  "L S = (rS. lang r)"

lemma L_mono: "S1  S2  L S1  L S2"
apply(simp) by blast

definition concS :: "'b rexp set  'b rexp set  'b rexp set" where
  "concS S1 S2 = {Times a b|a b. aS1  bS2}"

lemma substL_conc: "L (substL (L1 @@ L2) σ) = L (concS (substL L1 σ) (substL L2 σ))"
apply(simp add: concS_def conc_def)
apply(auto)
proof (goal_cases)
  case (1 x xs ys)
  show ?case
    apply(rule exI[where x="Times (subst (w2rexp xs) σ) (subst (w2rexp ys) σ)"])
    apply(simp)
    apply(safe)
     apply(rule exI[where x="xs"]) apply(simp add: 1(2))
     apply(rule exI[where x="ys"]) apply(simp add: 1(3))
     using 1(1) subst_w2rexp by auto
next
  case (2 x xs ys)
  show ?case
    apply(rule exI[where x="subst (w2rexp (xs @ ys)) σ"])
    apply(safe)
      apply(rule exI[where x="xs@ys"]) apply(simp)
        apply(rule exI[where x="xs"])
        apply(rule exI[where x="ys"]) using 2(2,3) apply(simp)
      using 2(1) subst_w2rexp by(auto)
qed

lemma L_conc: "L(concS M1 M2) = (L M1) @@ (L M2)"
proof -
  have "L(concS M1 M2) = (x{Times a b |a b. a  M1  b  M2}. lang x)" unfolding concS_def by(simp)
  also have " = ({lang (Times a b) |a b. a  M1  b  M2} )" by blast
  also have " = ({lang a @@ lang b |a b. a  M1  b  M2} )" by simp
  also have " = ({{xs@ys | xs ys. xs  lang a & ys  lang b} |a b. a  M1  b  M2} )" unfolding conc_def by simp
  also have " = {xs@ys | xs ys. xs (rM1. lang r)  ys  (rM2. lang r) }" by blast
  also have " = {xs@ys | xs ys. xs L(M1)  ys  L(M2) }" by simp
  also have " = (L M1) @@ (L M2)" unfolding conc_def by simp
  finally show ?thesis .
qed
  
lemma "L(M1  M2) = (L M1)  (L M2)"
by simp

fun verund :: "'b rexp list  'b rexp" where
  "verund [] = Zero"
| "verund [r] = r"
| "verund (r#rs) = Plus r (verund rs)"

lemma lang_verund: "r  L (set rs) = (r  lang (verund rs))"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

lemma obtainit: 
  assumes "r  lang (verund rs)"
  shows "x(set (rs::nat rexp list)). r  lang x"
proof -
  from assms have "r  L (set rs)" by(simp only: lang_verund)
  then show ?thesis by(auto)
qed



lemma lang_verund4: "L (set rs) = lang (verund rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

lemma lang_verund1: "r  L (set rs)  r  lang (verund rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto
lemma lang_verund2: "r  lang (verund rs)  r  L (set rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

definition starS :: "'b rexp set  'b rexp set" where
  "starS S = {Star (verund xs)|xs. set xs  S}"

lemma "[]  L (starS S)"
unfolding starS_def apply(simp)
  apply(rule exI[where x="Star(verund [])"])
  apply(simp)
    apply(rule exI[where x="[]"])
    by (simp)

lemma power_mono: "L1  L2  (L1::'a lang) ^^ n  L2 ^^ n"
apply(auto) apply(induct n) by(auto simp: conc_def)

lemma star_mono: "L1  L2  star L1  star L2"
  apply (simp add: star_def)
  apply (rule UN_mono)
  apply (auto simp: power_mono)
  done

lemma Lstar: "L(starS M) = star ( L(M) )"
unfolding starS_def apply(auto)
proof (goal_cases)
  case (1 x xs)
  from 1(2) have "L (set xs)  L (M)" by(rule L_mono)
  then have a: "star (L (set xs))  star (L (M))" by (rule star_mono)
  from 1(1) obtain n where "x  (lang (verund xs)) ^^ n" unfolding star_def by(auto)
  thm lang_verund4
  then have "x  (L (set xs)) ^^ n" by(simp only: lang_verund4)
  then have "x  star (L (set xs))" unfolding star_def by auto
  with a have "x  star (L (M))" by auto
  then show "x  star (xM. lang x)" unfolding starS_def by auto
next
  case (2 x)
  then obtain n where "x  (xM. lang x) ^^ n" unfolding star_def by auto
  then show ?case
  proof (induct n arbitrary: x)
    case 0
    then have t: "x=[]" by(simp)
    show ?case
      apply(rule exI[where x="Star Zero"])
      apply(auto simp: t) apply(rule exI[where x="[]"]) by(simp)
  next
    case (Suc n)
    from Suc(2) have t: "x  (aM. lang a) @@ (aM. lang a) ^^ n" by (simp)
    then obtain A B where x: "x = A @ B" and A: "A  (aM. lang a)" and B: "B  (aM. lang a) ^^ n" by(auto simp: conc_def)
    then obtain m where am: "A  lang m" and mM: "mM" by(auto)
    from Suc(1)[OF B] obtain b bs where "b = Star (verund bs)" and bsM: "set bs  M" "B  lang b" by auto
    then have Bin:  "B  lang (Star (verund bs))" by simp
    let ?c = "Star (verund (m#bs))"

    have ac: "lang m  lang (Star (verund (m # bs)))" 
      apply(cases bs) by(auto)
    have ad: "(lang (Star (verund bs)))  lang (Star (verund (m # bs)))"
      apply (simp add: star_def)
      apply (rule UN_mono)
      apply simp_all
      proof -
        fix n
        have t: "(lang (verund bs) ^^ n)  (lang m  lang (verund bs)) ^^ n"
          by (rule power_mono) simp
        then show "lang (verund bs) ^^ n
           lang (verund (m # bs)) ^^ n" by (cases bs) simp_all
      qed

    from Bin am mM x have "x  lang m @@ (lang (Star (verund bs)))" by auto
    then have " x  lang (Star (verund (m # bs))) @@ lang (Star (verund (m # bs)))" using ac ad by blast
    then have x_in: "x  lang (Star (verund (m # bs)))" by (auto)

    
    show ?case
      apply(rule exI[where x="?c"])
      apply(safe)
        apply(rule exI[where x="m#bs"]) apply(simp add: bsM mM)
        by(fact x_in)
  qed
qed        

lemma substL_star: "L (substL (star L1) σ) = L (starS (substL L1 σ))"
apply (simp add: concS_def conc_def starS_def star_def)
apply auto unfolding star_def
proof -
  fix x a n
  assume "x  lang (subst (w2rexp a) σ)"
  moreover assume "a  L1 ^^ n"
  ultimately show "xa. (xs. xa = Star (verund xs)  set xs
     {subst (w2rexp a) σ | a. a  L1})  x  lang xa"
  proof(induct n arbitrary: x a)
    case 0
    then have "a=[]" by auto
    with 0 show ?case apply(simp)
    apply(rule exI[where x="Star (Zero)"])
    apply(simp)
      apply(rule exI[where x="[]"])
      by(simp)
  next
    case (Suc n)
    then have a1: "a  L1 @@ L1 ^^ n" by auto
    then obtain A B where a2: "a = A @ B" and A: "A  L1" and B: "B  L1 ^^ n" by auto

    thm subst_w2rexp
    from Suc(2) have "x  lang (subst (w2rexp A) σ) @@ lang (subst (w2rexp B) σ)" unfolding a2
          by(simp only: subst_w2rexp)
    then obtain x1 x2 where x: "x = x1@x2" and x1: "x1  lang (subst (w2rexp A) σ)"
                    and  x2: "x2  lang (subst (w2rexp B) σ)" by auto
    from Suc(1)[OF x2 B] obtain R li where
          R: "R = Star (verund li)" and li: "set li  {subst (w2rexp a) σ |a. a  L1}"
              and x2R: "x2  lang R" by auto


    show ?case
      apply(rule exI[where x="Star (verund ((subst (w2rexp A) σ)#li))"])
      apply(simp)
      apply(safe)
        apply(rule exI[where x="((subst (w2rexp A) σ)#li)"])
        apply(simp add: li) 
          apply(rule exI[where x="A"]) apply(simp add: A)
        unfolding x
        proof (goal_cases)
          case 1
          let ?L = "(lang (subst (w2rexp A) σ)  lang (verund li))"
          have t1: "x1  ?L" using x1 star_mono by blast
          have t2: "x2  star ?L" using x2R R star_mono apply(simp) by blast
          have "x1 @ x2  (?L @@ star ?L)" using t1 t2 by auto
          then show ?case 
          apply(cases li) by(auto)
        qed
    qed
next
  fix x and xs :: "nat rexp list"
  assume "x  (n. lang (verund xs) ^^ n)"
  then obtain n where "x  lang (verund xs) ^^ n" by auto
  moreover assume "set xs  {subst (w2rexp a) σ |a. a  L1}"
  ultimately show "xa. (a. xa = subst (w2rexp a) σ 
    (n. a  L1 ^^ n))  x  lang xa"
  proof (induct n arbitrary: x)
    case 0
    then have xe: "x=[]" by auto
    show ?case
      apply(rule exI[where x="One"])
      apply(simp add: xe)
        apply(rule exI[where x="[]"])
        apply(simp)
          apply(rule exI[where x="0"])
          by(simp)
  next
    case (Suc n)
    then have "x  lang (verund xs) @@ (lang (verund xs) ^^ n)" by auto
    then obtain x1 x2 where x: "x=x1@x2" and x1: "x1lang (verund xs)"
                      and x2: "x2  (lang (verund xs) ^^ n)" by auto
    from obtainit [OF x1] obtain el
      where "el  set xs" and "x1  lang el" by auto
    with Suc.prems obtain elem
      where x1elem: "x1  lang (subst (w2rexp elem) σ)"
      and elemL1: "elem  L1" by auto
    from Suc.hyps [OF x2 Suc.prems(2)] obtain R word n where
         R: "R = subst (w2rexp word) σ" and word: "word  L1 ^^ n" and x2: "x2  lang R" by auto
    
                      
    show ?case
      apply(rule exI[where x="subst (w2rexp (elem@word)) σ"])
      apply(safe)
        apply(rule exI[where x="elem@word"])
        apply(simp)
          apply(rule exI[where x="Suc n"])
          proof (goal_cases)
            case 1
            have "elem  L1" by(fact elemL1)
            with word
            show "elem @ word  L1 ^^ Suc n" by simp
          next
            case 2
            have "x1  lang (subst (w2rexp elem) σ)" by(fact x1elem)
            with x2[unfolded R] show ?case unfolding x apply(simp only: subst_w2rexp) by blast
          qed
  qed
qed

lemma substituitionslemma: 
  fixes E :: "nat rexp"
  shows "L (substL ( lang(E) ) σ) = lang (subst E σ)"
proof (induct E)
  case (Star e)
  have "L (substL (lang (Star e)) σ) = L (substL (star (lang e)) σ)" by auto
  also have " = L (starS (substL (lang e) σ))" by(simp only: substL_star)
  also have " = star ( L (substL (lang e) σ))" by(simp only: Lstar)
  also have " = star (lang (subst e σ))" by(simp only: Star)
  also have " = lang ((subst (Star e) σ))" by auto
  finally show ?case .
next
  case (Plus e1 e2)
  have "L (substL (lang (Plus e1 e2)) σ) = L (substL (lang e1  lang e2) σ)" by simp
  also have " =  L ( substL (lang e1) σ  substL (lang e2) σ)" by auto
  also have " = L (substL (lang e1) σ)  L (substL (lang e2) σ)" by auto
  also have " = lang (subst e1 σ)  lang (subst e2 σ)" by(simp only: Plus)
  also have " = lang (subst (Plus e1 e2) σ)" by auto
  finally show ?case .
next
  case (Times e1 e2)
  have "L (substL (lang (Times e1 e2)) σ) = L (substL (lang e1 @@ lang e2) σ)" by(simp)
  also have " =  L (concS (substL (lang e1) σ) (substL (lang e2) σ))" by(simp only: substL_conc)
  thm L_conc
  also have " = L (substL (lang e1) σ) @@ L (substL (lang e2) σ)" by(simp only: L_conc)
  also have " = lang (subst e1 σ) @@ lang (subst e2 σ)" by(simp only: Times)
  also have " = lang (Times (subst e1 σ) (subst e2 σ))" by auto
  also have " = lang (subst (Times e1 e2) σ)" by auto
  finally show ?case .
qed simp_all


corollary lift: "lang e1 = lang e2  lang (subst e1 σ) = lang (subst e2 σ)"
proof -
  assume eq: "lang e1 = lang e2"
  thm substituitionslemma
  have "lang (subst e1 σ) = L (substL (lang e1) σ)" by(simp only: substituitionslemma)
  also have " = L (substL (lang e2) σ)" using eq by simp
  also have " = lang (subst e2 σ)" by(simp only: substituitionslemma)
  finally show ?thesis .
qed


subsection ‹Examples›

lemma "lang (Plus (Atom (x::nat)) (Atom x))  = lang (Atom x)"
proof -
  let  = "(λi. (if i=0 then Some (Atom x) else None))"
  let ?e1 = "Plus (Atom 1) (Atom 1)"
  let ?e2 = "Atom 1"
  have "lang (Plus (Atom x) (Atom x)) = lang (subst ?e1 )" by (simp)
  thm soundness
  also have " = lang (subst ?e2 )"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have " = lang (Atom x)" by auto
  finally show ?thesis .
qed


fun seq :: "'a rexp list  'a rexp" where
"seq [] = One" |
"seq [r] = r" |
"seq (r#rs) = Times r (seq rs)"


abbreviation question where "question x == Plus x One" 

definition "L_4cases (x::nat) y=
    verund [seq[question (Atom x),(Atom y), (Atom y)],
            seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)],
            seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)],
            seq[(Atom x),(Atom x)] ]"

definition "L_A x y = seq[question (Atom x),(Atom y), (Atom y)]"
definition "L_B x y = seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]"
definition "L_C x y = seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]"
definition "L_D x y = seq[(Atom x),(Atom x)]"

lemma "L_4cases x y = verund [L_A x y, L_B x y, L_C x y, L_D x y]"
unfolding L_A_def L_B_def L_C_def L_D_def L_4cases_def by auto


definition "L_lasthasxx x y = (Plus (seq[question (Atom x), Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)])
       (seq[question (Atom y), Star(Times(Atom x) (Atom y)),(Atom x),(Atom x)]))"



lemma lastxx_com: "lang (L_lasthasxx (x::nat) y) = lang (L_lasthasxx y x)" (is "lang ?A = lang ?B")
proof -
  let  = "(λi. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"
  
  let ?e1 = "Plus (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
       (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])"
  let ?e2 = "Plus (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])
           (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])"
  have "lang ?A = lang (subst ?e1 )" by(simp add: L_lasthasxx_def)
  thm soundness
  also have " = lang (subst ?e2 )"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have " = lang ?B" by (simp add: L_lasthasxx_def)
  finally show ?thesis .
qed


lemma lastxx_is_4cases: "lang (L_4cases x y) = lang (L_lasthasxx x y)" (is "lang ?A = lang ?B")
proof -
  let  = "(λi. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"
  
  let ?e1 = "(Plus (seq[Plus (Atom 1) One,(Atom 3), (Atom 3)])
            (Plus (seq[Plus (Atom 1) One,(Atom 3),(Atom 1),Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
            (Plus (seq[Plus (Atom 1) One,(Atom 3),(Atom 1),Star(Times (Atom 3) (Atom 1)),(Atom 1)])
                  (seq[(Atom 1),(Atom 1)]))))"
  let ?e2 = "Plus (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
       (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])"
  have "lang ?A = lang (subst ?e1 )" by (simp add: L_4cases_def)
  thm soundness
  also have " = lang (subst ?e2 )"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have " = lang ?B" by (simp add: L_lasthasxx_def)
  finally show ?thesis .
qed

definition "myUNIV x y = Star (Plus (Atom x) (Atom y))"


lemma myUNIV_alle: "lang (myUNIV x y) = {xs. set xs  {x,y}}"
proof -
  have "star {[y], [x]}  = {concat ws |ws. set ws  {[y], [x]}}" by(simp only: star_conv_concat)
  also have " = {xs. set xs  {x, y}}" apply(auto) apply(cases "x=y") apply(simp) 
        apply(case_tac ws)
          apply(simp)
          apply(auto)
        proof (goal_cases)
          case (1 as)
          then show ?case
            proof (induct as)
              case (Cons a as)
              then have as: "set as  {x,y}" and axy: "a  {x,y}" by auto
              from Cons(1)[OF as] obtain ws where asco: "as = concat ws" and ws: "set ws  {[y],[x]}" by auto
              show ?case
                apply(rule exI[where x="[a]#ws"])
                using axy by(auto simp add: asco ws)
            qed (rule exI[where x="[]"], simp)
          qed
   finally show ?thesis by(simp add: myUNIV_def)
qed

definition "nodouble x y = (Plus
                   (seq[question (Atom x), Star(Times(Atom y)(Atom x)),(Atom y)])
                   (seq[question (Atom y), Star(Times(Atom x) (Atom y)),(Atom x)]))"

lemma myUNIV_char: "lang (myUNIV (x::nat) y) = lang (Times (Star (L_lasthasxx x y)) (Plus One (nodouble x y)))" (is "lang ?A = lang ?B")
proof -
  let  = "(λi. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"
  
  let ?e1 = "Star (Plus (Atom 1) (Atom 3))"
  let ?e2 = "(Times (Star (Plus (seq [Plus (Atom 1) One, Star  (Times (Atom 3) (Atom 1)), Atom 3, Atom 3])
           (seq [Plus (Atom 3) One, Star (Times (Atom 1) (Atom 3)), Atom 1, Atom 1])))
       (Plus One
         (Plus
           (seq
             [Plus (Atom 1)
               One,
              Star
               (Times (Atom 3)
 (Atom 1)),
              Atom 3])
           (seq
             [Plus (Atom 3)
               One,
              Star
               (Times (Atom 1)
 (Atom 3)),
              Atom 1]))))"
  have "lang ?A = lang (subst ?e1 )" by(simp add: myUNIV_def)
  thm soundness
  also have " = lang (subst ?e2 )"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have " = lang ?B" by (simp add: L_lasthasxx_def nodouble_def)
  finally show ?thesis .
qed


definition "mycasexxy x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x, Atom x, Atom y])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom y, Atom x])"
definition "mycasexyx x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x, Atom y, Atom x])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom x, Atom y])"
definition "mycasexx x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x,  Atom x])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom y])"
definition "mycasexy x y = Plus (seq[Atom x,  Atom y]) (seq[Atom y, Atom x])"
definition "mycasex x y = Plus (Atom y) (Atom x)"



definition "mycases x y = Plus
                   (mycasexxy x y)
              (Plus (mycasexyx x y)
              (Plus (mycasexx x y) 
                    (Plus (mycasexy x y) (Plus (mycasex x y) (One)))))"
 
lemma mycases_char: "lang (myUNIV (x::nat) y) = lang (mycases x y)" (is "lang ?A = lang ?B")
proof -
  let  = "(λi. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"
  
  let ?e1 = "Star (Plus (Atom 1) (Atom 3))"
  let ?e2 = "Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 1, Atom 3])
           (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 3, Atom 1]))
     (Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 3, Atom 1])
             (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 1, Atom 3]))
       (Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 1])
               (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 3]))
         (Plus (Plus (seq [Atom 1, Atom 3]) (seq [Atom 3, Atom 1])) (Plus (Plus (Atom 3) (Atom 1)) One))))"

  have "lang ?A = lang (subst ?e1 )" by(simp add: myUNIV_def)
  thm soundness
  also have " = lang (subst ?e2 )"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have " = lang ?B" by (simp add:  mycases_def mycasexxy_def mycasexyx_def 
                                          mycasexx_def mycasex_def mycasexy_def)
  finally show ?thesis .
qed       
 

end

Theory OPT2

(*  Title:       Analysis of OPT2
    Author:      Max Haslbeck
*)

section "OPT2"

theory OPT2
imports 
Partial_Cost_Model
RExp_Var
begin

lemma "(N::nat set)  {}  Inf N : N"
unfolding Inf_nat_def using LeastI[of "%x. x : N"] by force

lemma nn_contains_Inf:
  fixes S :: "nat set"
  assumes nn: "S  {}"
  shows "Inf S  S"
using assms Inf_nat_def LeastI by force


subsection "Definition"

fun OPT2 :: "'a list  'a list  (nat * nat list) list" where
  "OPT2 [] [x,y] = []"
| "OPT2 [a] [x,y] = [(0,[])]"
| "OPT2 (a#b#σ') [x,y] =  (if a=x then (0,[]) # (OPT2 (b#σ') [x,y])
                                  else (if b=x then (0,[])# (OPT2 (b#σ') [x,y])
                                               else (1,[])# (OPT2 (b#σ') [y,x])))"
         

lemma OPT2_length: "length (OPT2 σ [x, y]) = length σ"
apply(induct σ arbitrary: x y)
  apply(simp)
  apply(case_tac σ) by(auto)

lemma OPT2x: "OPT2 (x#σ') [x,y] = (0,[])#(OPT2 σ' [x,y])"
apply(cases σ') by (simp_all)

 
lemma swapOpt: "Tp_opt [x,y] σ  1 + Tp_opt [y,x] σ"
proof -
  show ?thesis
  proof (cases "length σ > 0")
    case True

    have "Tp_opt [y,x] σ  {Tp [y, x] σ as |as. length as = length σ}"
    unfolding T_opt_def 
      apply(rule nn_contains_Inf)
      apply(auto) by (rule Ex_list_of_length)

    then obtain asyx where costyx: "Tp [y,x] σ asyx = Tp_opt [y,x] σ"
                       and lenyx: "length asyx = length σ"
              unfolding T_opt_def by auto

    from True lenyx have "length asyx > 0" by auto
    then obtain A asyx' where aa: "asyx = A # asyx'" using list.exhaust by blast
    then obtain m1 a1 where AA: "A = (m1,a1)" by fastforce
    
    let ?asxy = "(m1,a1@[0]) # asyx'"
    
    from True obtain q σ' where qq: "σ = q # σ'" using list.exhaust by blast
  
    have t: "tp [x, y] q (m1, a1@[0]) = Suc (tp [y, x] q (m1, a1))"
    unfolding tp_def
    apply(simp) unfolding swap_def by (simp)
  
    have s: "step [x, y] q (m1, a1 @ [0]) = step [y, x] q (m1, a1)" 
    unfolding step_def mtf2_def by(simp add: swap_def)
  
    have T: "Tp [x,y] σ ?asxy = 1 + Tp [y,x] σ asyx" unfolding qq aa AA by(auto simp add: s t)
   
    have l: "1 + Tp_opt [y,x] σ = Tp [x, y] σ ?asxy" using T costyx by simp
    have "length ?asxy = length σ" using lenyx aa by auto
    then have inside: "?asxy  {as. size as = size σ}" by force
    then have b: "Tp [x, y] σ ?asxy  {Tp [x, y] σ as | as. size as = size σ}" by auto

    then show ?thesis unfolding l unfolding T_opt_def
      apply(rule cInf_lower) by simp
  qed (simp add: T_opt_def)         
qed


lemma tt: "a  {x,y}  OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))
       = tl (OPT2 (a # rest1) [x, y])"
apply(cases rest1) by(auto simp add: step_def mtf2_def swap_def)

lemma splitqsallg: "Strat  []  a  {x,y} 
         tp [x, y] a (hd (Strat)) +
          (let L=step [x,y] a (hd (Strat)) 
              in Tp L (rest1) (tl Strat)) =  Tp [x, y] (a # rest1) Strat"
proof -
  assume ne: "Strat  []"
  assume axy: "a  {x,y}" (* not needed *)
  have "Tp [x, y] (a # rest1) (Strat) 
        = Tp [x, y] (a # rest1) ((hd (Strat)) # (tl (Strat)))"
        by(simp only: List.list.collapse[OF ne])
  then show ?thesis by auto
qed

lemma splitqs: "a  {x,y}  Tp [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
        =  tp [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y])) 
              in Tp L (rest1) (OPT2 (rest1) L))"
proof -
  assume axy: "a  {x,y}"
  have ne: "OPT2 (a # rest1) [x, y]  []" apply(cases rest1) by(simp_all)
  have "Tp [x, y] (a # rest1) (OPT2 (a # rest1) [x, y]) 
        = Tp [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (tl (OPT2 (a # rest1) [x, y])))"
        by(simp only: List.list.collapse[OF ne])
  also have " = Tp [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))))"
      by(simp only: tt[OF axy])
  also have " =   tp [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y])) 
              in Tp L (rest1) (OPT2 (rest1) L))" by(simp)
  finally show ?thesis .
qed

lemma tpx: "tp [x, y] x (hd (OPT2 (x # rest1) [x, y])) = 0"
by (simp add: OPT2x tp_def)

lemma yup: "Tp [x, y] (x # rest1) (OPT2 (x # rest1) [x, y])
        = (let L=step [x,y] x (hd (OPT2 (x # rest1) [x, y])) 
              in Tp L (rest1) (OPT2 (rest1) L))"
by (simp add: splitqs tpx)

lemma swapsxy: "A  { [x,y], [y,x]}  swaps sws A  { [x,y], [y,x]}"
apply(induct sws)
  apply(simp)
  apply(simp) unfolding swap_def by auto

lemma mtf2xy: "A  { [x,y], [y,x]}  r{x,y}  mtf2 a r A  { [x,y], [y,x]}"
by (metis mtf2_def swapsxy)


lemma stepxy: assumes "q  {x,y}" "A  { [x,y], [y,x]}" 
    shows "step A q a  { [x,y], [y,x]}"
unfolding step_def apply(simp only: split_def Let_def)
apply(rule mtf2xy)
  apply(rule swapsxy) by fact+ 


subsection "Proof of Optimality"

lemma OPT2_is_lb: "set σ  {x,y}  xy  Tp [x,y] σ (OPT2 σ [x,y])  Tp_opt [x,y] σ" 
proof (induct "length σ" arbitrary: x y σ rule: less_induct)
  case (less)
  show ?case
  proof (cases σ)
    case (Cons a σ')
    note Cons1=Cons
    show ?thesis unfolding Cons
      proof(cases "a=x") (* case that the element in front is requested *)
        case True
        from True Cons have qsform: "σ = x#σ'" by auto
        have up: "Tp [x, y] (x # σ') (OPT2 (x # σ') [x, y])  Tp_opt [x, y] (x # σ')"
          unfolding True
          unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el  {Tp [x, y] (x # σ') as |as. length as = length (x # σ')}"
              then obtain Strat where lStrat: "length Strat = length (x # σ')"
                        and el: "Tp [x, y] (x # σ') Strat = el" by auto
              then have ne: "Strat  []" by auto
              let ?LA="step [x,y] x (hd (OPT2 (x # σ') [x, y]))"
              
              have  E0:  "Tp [x, y] (x # σ') (OPT2 (x # σ') [x, y])
                            =Tp ?LA (σ') (OPT2 (σ') ?LA)" using yup by auto
              also have E1: " = Tp [x,y] (σ') (OPT2 (σ') [x,y])" by (simp add: OPT2x step_def)
              also have E2: "   Tp_opt [x,y] σ'" apply(rule less(1)) using Cons less(2,3) by auto
              also have "  Tp [x, y] (x # σ') Strat"
                   proof (cases "(step [x, y] x (hd Strat)) = [x,y]")
                      case True
                      have aha: "Tp_opt [x, y] σ'  Tp [x, y] σ' (tl Strat)"                     
                        unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto

                      also have E4: "  tp [x, y] x (hd Strat) + Tp (step [x, y] x (hd Strat)) σ' (tl Strat)" 
                        unfolding True by(simp)
                      also have E5: " = Tp [x, y] (x # σ') Strat" using splitqsallg[of Strat x x y σ', OF ne, simplified]
                        by (auto)
                      finally show ?thesis by auto 
                   next
                      case False
                      have tp1: "tp [x, y] x (hd Strat)  1"
                      proof (rule ccontr)
                        let ?a = "hd Strat"
                        assume "¬ 1  tp [x, y] x ?a"
                        then have tp0: "tp [x, y] x ?a = 0" by auto
                        then have "size (snd ?a) = 0" unfolding tp_def by(simp add: split_def)
                        then have nopaid: "(snd ?a) = []" by auto
                        have "step [x, y] x ?a = [x, y]"
                          unfolding step_def apply(simp add: split_def nopaid)
                          unfolding mtf2_def by(simp)
                        then show "False" using False by auto
                      qed

                      from False have yx: "step [x, y] x (hd Strat) = [y, x]"
                        using stepxy[where x=x and y=y and a="hd Strat"] by auto

                      have E3: "Tp_opt [x, y] σ'  1 + Tp_opt [y, x] σ'" using swapOpt by auto
                      also have E4: "  1 + Tp [y, x] σ' (tl Strat)"        
                        apply(simp) unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto
                      also have E5: " = 1 + Tp (step [x, y] x (hd Strat)) σ' (tl Strat)" using yx by auto
                      also have E6: "  tp [x, y] x (hd Strat) + Tp (step [x, y] x (hd Strat)) σ' (tl Strat)" using tp1 by auto
                      
                      also have E7: " = Tp [x, y] (x # σ') Strat" using splitqsallg[of Strat x x y σ', OF ne, simplified]
                         by (auto)
                      finally show ?thesis by auto
                   qed
              also have " = el" using True el by simp
              finally show "Tp [x, y] (x # σ') (OPT2 (x # σ') [x, y])  el" by auto        
            qed
         then show "Tp [x, y] (a # σ') (OPT2 (a # σ') [x, y])  Tp_opt [x, y] (a # σ')"
         using True by simp
      next


        case False (* case 2: element at back is requested first *)
        with less Cons have ay: "a=y" by auto
        show "Tp [x, y] (a # σ') (OPT2 (a # σ') [x, y])  Tp_opt [x, y] (a # σ')" unfolding ay
        proof(cases σ')
          case Nil
          have up: "Tp_opt [x, y] [y]  1"
            unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el  {Tp [x, y] [y] as |as. length as = length [y]}"
              then obtain Strat where Strat: "length Strat = length [y]" and
                            el: "el = Tp [x, y] [y] Strat " by auto
              from Strat obtain a where a: "Strat = [a]" by (metis Suc_length_conv length_0_conv)
              show "1  el" unfolding el a apply(simp) unfolding tp_def apply(simp add: split_def)
                apply(cases "snd a")
                  apply(simp add: less(3))
                  by(simp)
            qed

          show "Tp [x, y] (y # σ') (OPT2 (y # σ') [x, y])  Tp_opt [x, y] (y # σ')" unfolding Nil
            apply(simp add: tp_def) using less(3) apply(simp)
            using up by(simp)
        next
          case (Cons b rest2)

          show up: "Tp [x, y] (y # σ') (OPT2 (y # σ') [x, y])  Tp_opt [x, y] (y # σ')"
            unfolding Cons
          proof (cases "b=x")
            case True
            
            show "Tp [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y])  Tp_opt [x, y] (y # b # rest2)"
              unfolding True
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el  {Tp [x, y] (y # x # rest2) as |as. length as = length (y # x # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # x # rest2)" and
                               Strat: "el = Tp [x, y] (y # x # rest2) Strat" by auto
                  have v: " set rest2  {x, y}" using less(2)[unfolded Cons1 Cons] by auto
                  
                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 x (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)
                  
                  


                  have 1: "Tp [x, y] (y # x # rest2) Strat
                        = tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))
                            + Tp ?L2 rest2 (tl (tl Strat))"  
                    proof - 
                      have a: "Strat  []" using lenStrat by auto
                      have b: "(tl Strat)  []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "Tp [x, y] (y # x # rest2) Strat
                                = tp [x, y] y (hd Strat) + Tp ?L1 (x # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat)  [x, y]  step [x, y] y (hd Strat) = [y,x]" 
                        using stepxy[where A="[x,y]"] by blast

                      have 2: "Tp ?L1 (x # rest2) (tl Strat) = tp ?L1 x (hd (tl Strat)) +  Tp ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=x and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=x and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " Tp [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y])
                    =  1 +  Tp [x, y] (rest2) (OPT2 (rest2) [x, y])"
                    unfolding True
                    using less(3) by(simp add: tp_def step_def OPT2x)
                  also have "  1 +  Tp_opt [x, y] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      apply(fact) by fact
                  also

                  have "  Tp [x, y] (y # x # rest2) Strat"
                  proof (cases "?L2 = [x,y]")
                    case True
                    have 2: "tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))
                            + Tp [x,y] rest2 (tl (tl Strat))  tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))
                            + Tp_opt [x,y] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))
                            + Tp_opt [x,y] rest2  1 + Tp_opt [x,y] rest2" apply(simp)
                            proof -
                              have "tp [x, y] y (hd Strat)  1"
                              unfolding tp_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0  tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto
                  next
                    case False
                    note L2F=this
                    have L1: "?L1  {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2  {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [y,x]" by auto

                    have k: "Tp [x, y] (y # x # rest2) Strat
                        =   tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat)) +
                            Tp [y,x] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "tp [x, y] y (hd Strat) > 0"
                        using less(3) unfolding tp_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "Tp [x, y] (y # x # rest2) Strat  2 + Tp [y,x] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [x,y]")
                      case True
                      note T=this
                      then have "tp ?L1 x (hd (tl Strat)) > 0" unfolding True
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [x,y]" unfolding T  apply(simp add: split_def step_def) 
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < tp [x, y] x (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < tp [x, y] x (hd (tl Strat))"
                            unfolding tp_def by(simp add: split_def)
                        qed                          
                      with l have " tp [x, y] y (hd Strat) + tp ?L1 x (hd (tl Strat))  2" by auto
                      with k show ?thesis by auto
                    next
                      case False
                      from L1 False have 2: "?L1 = [y,x]" by auto
                      { fix k sws T
                        have "T{[x,y],[y,x]}  mtf2 k x T = [y,x]  T = [y,x]"
                          apply(rule ccontr) by (simp add: less(3) mtf2_def)
                      }
                      have t1: "tp [x, y] y (hd Strat)  1" unfolding tp_def apply(simp add: split_def)
                        apply(cases "(snd (hd Strat))") using x  y by auto
                      have t2: "tp [y,x] x (hd (tl Strat))  1" unfolding tp_def apply(simp add: split_def)
                        apply(cases "(snd (hd (tl Strat)))") using x  y by auto
                      have "Tp [x, y] (y # x # rest2) Strat
                          = tp [x, y] y (hd Strat) + tp (step [x, y] y (hd Strat)) x (hd (tl Strat)) + Tp [y, x] rest2 (tl (tl Strat))"
                            by(rule k)
                      with t1 t2 2 show ?thesis by auto
                    qed
                    have t: "Tp [y, x] rest2 (tl (tl Strat))  Tp_opt [y, x] rest2" 
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + Tp_opt [x, y] rest2  2 + Tp_opt [y, x] rest2"
                      using  swapOpt by auto
                      also have "  2 + Tp [y, x] rest2 (tl (tl Strat))" using t by auto
                      also have "  Tp [x, y] (y # x # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed
                      
                  qed
                  also have " = el" using Strat by auto
                  finally show "Tp [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y])  el" .
                qed


          next
            case False
            with Cons1 Cons less(2) have bisy: "b=y" by auto
            with less(3) have "OPT2 (y # b # rest2) [x, y] = (1,[])# (OPT2 (b#rest2) [y,x])" by simp
            show "Tp [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y])  Tp_opt [x, y] (y # b # rest2)" 
              unfolding bisy
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el  {Tp [x, y] (y # y # rest2) as |as. length as = length (y # y # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # y # rest2)" and
                               Strat: "el = Tp [x, y] (y # y # rest2) Strat" by auto
                  have v: " set rest2  {x, y}" using less(2)[unfolded Cons1 Cons] by auto

                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 y (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)
                  
                  


                  have 1: "Tp [x, y] (y # y # rest2) Strat
                        = tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))
                            + Tp ?L2 rest2 (tl (tl Strat))" 
                    proof - 
                      have a: "Strat  []" using lenStrat by auto
                      have b: "(tl Strat)  []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "Tp [x, y] (y # y # rest2) Strat
                                = tp [x, y] y (hd Strat) + Tp ?L1 (y # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat)  [x, y]  step [x, y] y (hd Strat) = [y,x]" 
                        using stepxy[where A="[x,y]"] by blast
                     
                      have 2: "Tp ?L1 (y # rest2) (tl Strat) = tp ?L1 y (hd (tl Strat)) +  Tp ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=y and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=y and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " Tp [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y])
                    =  1 +  Tp [y, x] (rest2) (OPT2 (rest2) [y, x])" 
                    using less(3) by(simp add: tp_def step_def mtf2_def swap_def OPT2x)
                  also have "  1 +  Tp_opt [y, x] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      using v less(3) by(auto)
                  also

                  have "  Tp [x, y] (y # y # rest2) Strat"
                  proof (cases "?L2 = [y,x]")
                    case True
                    have 2: "tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))
                            + Tp [y,x] rest2 (tl (tl Strat))  tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))
                            + Tp_opt [y,x] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))
                            + Tp_opt [y,x] rest2  1 + Tp_opt [y,x] rest2" apply(simp)
                            proof -
                              have "tp [x, y] y (hd Strat)  1"
                              unfolding tp_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0  tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto 
                  next
                    case False 
                    note L2F=this
                    have L1: "?L1  {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2  {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [x,y]" by auto

                    have k: "Tp [x, y] (y # y # rest2) Strat
                        =   tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat)) +
                            Tp [x,y] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "tp [x, y] y (hd Strat) > 0"
                        using less(3) unfolding tp_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "Tp [x, y] (y # y # rest2) Strat  2 + Tp [x,y] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [y,x]")  
                      case False
                      from L1 False have "?L1 = [x,y]" by auto
                      note T=this
                      then have "tp ?L1 y (hd (tl Strat)) > 0" unfolding T
                      unfolding tp_def apply(simp add: split_def)
                        apply(cases "snd (hd (tl Strat)) = []")
                          using x  y by auto
                      with l k show ?thesis by auto
                    next

                      case True
                      note T=this
                          
                        have "tp ?L1 y (hd (tl Strat)) > 0" unfolding T
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [y,x]" unfolding T  apply(simp add: split_def step_def) 
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < tp [y, x] y (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < tp [y, x] y (hd (tl Strat))"
                            unfolding tp_def by(simp add: split_def)
                        qed                          
                      with l have " tp [x, y] y (hd Strat) + tp ?L1 y (hd (tl Strat))  2" by auto
                      with k show ?thesis by auto
                    
                    qed
                    have t: "Tp [x, y] rest2 (tl (tl Strat))  Tp_opt [x, y] rest2" 
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + Tp_opt [y, x] rest2  2 + Tp_opt [x, y] rest2"
                      using  swapOpt by auto
                      also have "  2 + Tp [x, y] rest2 (tl (tl Strat))" using t by auto
                      also have "  Tp [x, y] (y # y # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed
                      
                  qed
                  also have " = el" using Strat by auto
                  finally show "Tp [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y])  el" .
                qed
          qed
        qed
     qed
  qed (simp add: T_opt_def)
qed


lemma OPT2_is_ub: "set qs  {x,y}  xy  Tp [x,y] qs (OPT2 qs [x,y])  Tp_opt [x,y] qs"
  unfolding T_opt_def apply(rule cInf_lower)
            apply(simp) apply(rule exI[where x="(OPT2 qs [x, y])"])
            by (auto simp add: OPT2_length)



lemma OPT2_is_opt: "set qs  {x,y}  xy  Tp [x,y] qs (OPT2 qs [x,y]) = Tp_opt [x,y] qs"
by (simp add: OPT2_is_lb OPT2_is_ub antisym)


subsection "Performance on the four phase forms"

lemma OPT2_A: assumes "x  y" "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "Tp [x,y] qs (OPT2 qs [x,y]) = 1"
proof -
  from assms(2) obtain u v where qs: "qs=u@v" and u: "u=[x]  u=[]" and v: "v = [y,y]" by (auto simp: conc_def)
  from u have pref1: "Tp [x,y] (u@v) (OPT2 (u@v) [x,y]) = Tp [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x tp_def step_def)

  have ende: "Tp [x,y] v (OPT2 v [x,y]) = 1" unfolding v using assms(1) by(simp add: mtf2_def swap_def tp_def step_def)

  from pref1 ende qs show ?thesis by auto
qed
  

lemma OPT2_A': assumes "x  y" "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "real (Tp [x,y] qs (OPT2 qs [x,y])) = 1"
using OPT2_A[OF assms] by simp


lemma OPT2_B: assumes "x  y" "qs=u@v" "u=[]  u=[x]" "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "Tp [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "Tp [x,y] (u@v) (OPT2 (u@v) [x,y]) = Tp [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x tp_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and "alang (Times (Atom y) (Atom x))" and w: "wlang (seq[Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto)
  from this(2) have aa: "a=[y,x]" by(simp add: conc_def)

  from assms(1) this v have pref2: "Tp [x,y] v (OPT2 v [x,y]) = 1 + Tp [x,y] w (OPT2 w [x,y])"
   by(simp add: tp_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c  lang (Star (Times (Atom y) (Atom x)))" and d: "d  lang (Times (Atom y) (Atom y))" by auto
  then have dd: "d=[y,y]" by auto

  from c[simplified] have star: "Tp [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  Tp [x,y] d (OPT2 d [x,y])"
    proof(induct c rule: star_induct)
      case (append r s)       
      then have r: "r=[y,x]" by auto
      then have "Tp [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = Tp [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have " = 1 + Tp [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: tp_def step_def OPT2x)
      also have " =  1 + length s div 2 + Tp [x, y] d (OPT2 d [x, y])" using append by simp
      also have " =  length (r @ s) div 2 + Tp [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case .
    qed simp

  have ende: "Tp [x,y] d (OPT2 d [x,y]) = 1" unfolding dd using assms(1) by(simp add: mtf2_def swap_def tp_def step_def)
  
  have vv: "v = [y,x]@c@[y,y]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "Tp [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2 + 1" unfolding assms(2) by auto
  also have " = (length v div 2)" using vv by auto
  finally show ?thesis .
qed

lemma OPT2_B1: assumes "x  y" "qs  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "real (Tp [x,y] qs (OPT2 qs [x,y])) = length qs / 2"
proof -
  from assms(2) have qs: "qs  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 0"
  proof -
    from assms(2) have "qs  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length qs = 4+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show ?thesis by auto
  qed
  with OPT2_B[where u="[]", OF assms(1) _ _ qs] show ?thesis by auto
qed  
  
lemma OPT2_B2: assumes "x  y" "qs  lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "Tp [x,y] qs (OPT2 qs [x,y]) = ((length qs - 1) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 0"
  proof -
    from vv have "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by(auto simp add: conc_def)
    with pqr have a: "length v = 4+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show ?thesis by auto
  qed
  with OPT2_B[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis by(auto)
qed 

lemma OPT2_C: assumes "x  y" "qs=u@v" "u=[]  u=[x]" 
  and "v  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "Tp [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "Tp [x,y] (u@v) (OPT2 (u@v) [x,y]) = Tp [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x tp_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and aa: "a=[y,x]" and w: "wlang (seq[Star(Times (Atom y) (Atom x)), Atom x])" by(auto simp: conc_def)

  from assms(1) this v have pref2: "Tp [x,y] v (OPT2 v [x,y]) = 1 + Tp [x,y] w (OPT2 w [x,y])"
   by(simp add: tp_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c  lang (Star (Times (Atom y) (Atom x)))" and d: "d  lang (Atom x)" by auto
  then have dd: "d=[x]" by auto

  from c[simplified] have star: "Tp [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  Tp [x,y] d (OPT2 d [x,y])  (length c) mod 2 = 0"
    proof(induct c rule: star_induct)
      case (append r s)
      from append have mod: "length s mod 2 = 0" by simp
      from append have r: "r=[y,x]" by auto
      then have "Tp [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = Tp [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have " = 1 + Tp [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: tp_def step_def OPT2x)
      also have " =  1 + length s div 2 + Tp [x, y] d (OPT2 d [x, y])" using append by simp
      also have " =  length (r @ s) div 2 + Tp [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case by(simp add: mod r)
    qed simp

  have ende: "Tp [x,y] d (OPT2 d [x,y]) = 0" unfolding dd using assms(1) by(simp add: mtf2_def swap_def tp_def step_def)
  
  have vv: "v = [y,x]@c@[x]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "Tp [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2" unfolding assms(2) by auto
  also have " = (length v div 2)" using vv star by auto
  finally show ?thesis .
qed

lemma OPT2_C1: assumes "x  y" "qs  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "real (Tp [x,y] qs (OPT2 qs [x,y])) = (length qs - 1) / 2"
proof -
  from assms(2) have qs: "qs  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 1"
  proof -
    from assms(2) have "qs  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by auto
    with pqr have a: "length qs = 3+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show ?thesis by auto
  qed
  with OPT2_C[where u="[]", OF assms(1) _ _ qs] show ?thesis apply auto
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral) 
qed  
  
lemma OPT2_C2: assumes "x  y" "qs  lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "Tp [x,y] qs (OPT2 qs [x,y]) = ((length qs - 2) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 1"
  proof -
    from vv have "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by(auto simp add: conc_def)
    with pqr have a: "length v = 3+length q" by auto
    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show ?thesis by auto
  qed
  with OPT2_C[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis apply(auto)
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)     
qed 



lemma OPT2_ub: "set qs  {x,y}  Tp [x,y] qs (OPT2 qs [x,y])  length qs"
proof(induct qs arbitrary: x y)
  case (Cons q qs)
  then have "set qs  {x,y}" "q{x,y}" by auto
  note Cons1=Cons this
  show ?case
  proof (cases qs)
    case Nil
    with Cons1 show "Tp [x,y] (q # qs) (OPT2 (q # qs) [x,y])  length (q # qs)"
        apply(simp add: tp_def) by blast
  next
    case (Cons q' qs')
    with Cons1 have "q'{x,y}" by auto
    note Cons=Cons this

    from Cons1 Cons have T: "Tp [x, y] qs (OPT2 qs [x, y])  length qs"
                            "Tp [y, x] qs (OPT2 qs [y, x])  length qs" by auto
    show "Tp [x,y] (q # qs) (OPT2 (q # qs) [x,y])  length (q # qs)"
          unfolding Cons apply(simp only: OPT2.simps)
          apply(split if_splits(1))
            apply(safe)
            proof (goal_cases)
              case 1
              have "Tp [x, y] (x # q' # qs') ((0, []) # OPT2 (q' # qs') [x, y])
                      = tp [x, y] x (0,[]) + Tp [x, y] qs (OPT2 qs [x, y])"
                        by(simp add: step_def Cons)
              also have "  tp [x, y] x (0,[]) + length qs" using T by auto
              also have "  length (x # q' # qs')" using Cons by(simp add: tp_def)
              finally show ?case .
            next
              case 2
              with Cons1 Cons show ?case
                apply(split if_splits(1))
                apply(safe)
                proof (goal_cases)
                  case 1
                  then have "Tp [x, y] (y # x # qs') ((0, []) # OPT2 (x # qs') [x, y])
                          = tp [x, y] y (0,[]) + Tp [x, y] qs (OPT2 qs [x, y])"
                            by(simp add: step_def)
                  also have "  tp [x, y] y (0,[]) + length qs" using T by auto
                  also have "  length (y # x # qs')" using Cons by(simp add: tp_def)
                  finally show ?case .
                next
                  case 2
                  then have "Tp [x, y] (y # y # qs') ((1, []) # OPT2 (y # qs') [y, x])
                          = tp [x, y] y (1,[]) + Tp [y, x] qs (OPT2 qs [y, x])"
                            by(simp add: step_def mtf2_def swap_def)
                  also have "  tp [x, y] y (1,[]) + length qs" using T by auto
                  also have "  length (y # y # qs')" using Cons by(simp add: tp_def)
                  finally show ?case .
                qed
           qed
  qed
qed simp 

lemma OPT2_padded: "R{[x,y],[y,x]}  set qs  {x,y} 
        Tp R (qs@[x,x]) (OPT2 (qs@[x,x]) R)
               Tp R (qs@[x]) (OPT2 (qs@[x]) R) + 1"
apply(induct qs arbitrary: R)
  apply(simp)
    apply(case_tac "R=[x,y]")
      apply(simp add: step_def tp_def )
      apply(simp add: step_def mtf2_def swap_def tp_def)
  proof (goal_cases)
    case (1 a qs R)
    then have a: "a  {x,y}" by auto 
    with 1 show ?case
      apply(cases qs)
        apply(cases "a=x")
          apply(cases "R=[x,y]")
            apply(simp add: step_def tp_def)
            apply(simp add: step_def mtf2_def swap_def tp_def)
          apply(cases "R=[x,y]")
            apply(simp add: step_def tp_def)
            apply(simp add: step_def mtf2_def swap_def tp_def)
      proof (goal_cases)
        case (1 p ps)
        show ?case
          apply(cases "a=x")
            apply(cases "R=[x,y]")
              apply(simp add: OPT2x step_def) using 1 apply(simp)
              using 1(2) apply(simp)
                apply(cases qs)
                  apply(simp add: step_def mtf2_def swap_def tp_def)
                  using 1 by(auto simp add: swap_def mtf2_def step_def)
       qed
qed 


lemma  OPT2_split11:
  assumes xy: "xy"
  shows "R{[x,y],[y,x]}  set xs  {x,y}  set ys  {x,y}  OPT2 (xs@[x,x]@ys) R = OPT2 (xs@[x,x]) R @ OPT2 ys [x,y]"
proof (induct xs arbitrary: R)
  case Nil
  then show ?case
  apply(simp)
  apply(cases ys)
    apply(simp)
    apply(cases "R=[x,y]") 
      apply(simp)
      by(simp)
next
  case (Cons a as)
  note iH=this
  then have AS: "set as  {x,y}" and A: "a  {x,y}" by auto
  note iH=Cons(1)[where R="[y,x]", simplified, OF AS Cons(4)]
  note iH'=Cons(1)[where R="[x,y]", simplified, OF AS Cons(4)]
  show ?case
  proof (cases "R=[x,y]")
    case True
    note R=this
    from iH iH' show ?thesis
    apply(cases "a=x")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R)
        using AS apply(simp)
        apply(case_tac "aa=x")
          by(simp_all add: R)
  next
    case False
    with Cons(2) have R: "R=[y,x]" by auto
    from iH iH' show ?thesis
    apply(cases "a=y")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R) 
        apply(case_tac "aa=y")
          by (simp_all add: R)
   qed  
qed  
 
subsection "The function steps" 
 
 
lemma steps_append: "length qs = length as  steps s (qs@[q]) (as@[a]) = step (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2) by simp_all
 
end

Theory Phase_Partitioning

(*  Title:       Phase Partitioning
    Author:      Max Haslbeck
*)

section "Phase Partitioning"

theory Phase_Partitioning
imports OPT2
begin


subsection "Definition of Phases"

definition "other a x y = (if a=x then y else x)"


definition Lxx where
  "Lxx (x::nat) y = lang (L_lasthasxx x y)"

lemma Lxx_not_nullable: "[]  Lxx x y"
unfolding Lxx_def L_lasthasxx_def by simp

(* lemma set_Lxx: "xs ∈ Lxx x y ⟹ set xs ⊆ {x,y}"
unfolding Lxx_def L_lasthasxx_def apply(simp add: star_def) sle dgehammer *)


lemma Lxx_ends_in_two_equal: "xs  Lxx x y  pref e. xs = pref @ [e,e]"
by(auto simp: conc_def Lxx_def L_lasthasxx_def) 


lemma "Lxx x y = Lxx y x" unfolding Lxx_def by(rule lastxx_com)

definition "hideit x y = (Plus rexp.One (nodouble x y))"

lemma Lxx_othercase: "set qs  {x,y}  ¬ (xs ys. qs = xs @ ys  xs  Lxx x y)  qs  lang (hideit x y)"
proof -
  assume "set qs  {x,y}"
  then have "qs  lang (myUNIV x y)" using myUNIV_alle[of x y] by blast
  then have "qs  star (lang (L_lasthasxx x y)) @@  lang (hideit x y)" unfolding hideit_def
    by(auto simp add: myUNIV_char)
  then have qs: "qs  star (Lxx x y) @@  lang (hideit x y)" by(simp add: Lxx_def)
  assume notpos: "¬ (xs ys. qs = xs @ ys  xs  Lxx x y)"
  show "qs  lang (hideit x y)"
  proof -
    from qs obtain A B where qsAB: "qs=A@B" and A: "Astar (Lxx x y)" and B: "Blang (hideit x y)" by auto
    with notpos have notin: "A  (Lxx x y)" by blast
    
    from A have 1: "A = []  A  (Lxx x y) @@ star (Lxx x y)" using Regular_Set.star_unfold_left by auto
    have 2: "A  (Lxx x y) @@ star (Lxx x y)"
    proof (rule ccontr)
      assume "¬ A  Lxx x y @@ star (Lxx x y)"
      then have " A  Lxx x y @@ star (Lxx x y)" by auto
      then obtain A1 A2 where "A=A1@A2" and A1: "A1(Lxx x y)" and "A2 star (Lxx x y)" by auto
      with qsAB have "qs=A1@(A2@B)" "A1(Lxx x y)" by auto
      with notpos have "A1  (Lxx x y)" by blast
      with A1 show "False" by auto
    qed
    from 1 2 have "A=[]" by auto
    with qsAB have "qs=B" by auto
    with B show ?thesis by simp
  qed
qed


fun pad where "pad xs x y = (if xs=[] then [x,x] else 
                                    (if last xs = x then xs @ [x] else xs @ [y]))"

lemma pad_adds2: "qs  []  set qs  {x,y}  pad qs x y = qs @ [last qs]"
apply(auto) by (metis insertE insert_absorb insert_not_empty last_in_set subset_iff) 


lemma nodouble_padded: "qs  []  qs  lang (nodouble x y)  pad qs x y  Lxx x y"
proof -
  assume nn: "qs  []"
  assume "qs  lang (nodouble x y)"
  then have a: "qs  lang         (seq
          [Plus (Atom x) rexp.One,
           Star (Times (Atom y) (Atom x)),
           Atom y])  qs  lang
        (seq
          [Plus (Atom y) rexp.One,
           Star (Times (Atom x) (Atom y)),
           Atom x])"  unfolding nodouble_def by auto


  show ?thesis
  proof (cases "qs  lang (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)), Atom y])")
    case True
    then have "qs  lang (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x))]) @@ {[y]}"
      by(simp add: conc_assoc)
    then have "last qs = y" by auto
    with nn have p: "pad qs x y = qs @ [y]" by auto
    have A: "pad qs x y  lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y]) @@ {[y]}" unfolding p
             apply(simp)
             apply(rule concI)
              using True by auto
    have B: "lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y]) @@ {[y]} = lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y, Atom y])" by (simp add: conc_assoc)
    show "pad qs x y  Lxx x y" unfolding Lxx_def L_lasthasxx_def 
      using B A by auto
  next
    case False
    with a have T: "qs  lang (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)), Atom x])" by auto

    then have "qs  lang (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y))]) @@ {[x]}"
      by(simp add: conc_assoc)
    then have "last qs = x" by auto
    with nn have p: "pad qs x y = qs @ [x]" by auto
    have A: "pad qs x y  lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x]) @@ {[x]}" unfolding p
             apply(simp)
             apply(rule concI)
              using T by auto
    have B: "lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x]) @@ {[x]} = lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x, Atom x])" by (simp add: conc_assoc)
    show "pad qs x y  Lxx x y" unfolding Lxx_def L_lasthasxx_def 
      using B A by auto
 qed
qed

thm UnE
lemma "c  A  B  P"
  apply(erule UnE) oops

lemma LxxE: "qs  Lxx x y
     (qs  lang (seq [Atom x, Atom x])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])  P x y qs)
     P x y qs"
unfolding Lxx_def lastxx_is_4cases[symmetric] L_4cases_def apply(simp only: verund.simps lang.simps)
using UnE by blast

thm UnE LxxE

lemma "qs  Lxx x y  P"
apply(erule LxxE) oops

lemma LxxI: "(qs  lang (seq [Atom x, Atom x])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])  P x y qs)
     (qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])  P x y qs)
     (qs  Lxx x y  P x y qs)"
unfolding Lxx_def lastxx_is_4cases[symmetric] L_4cases_def apply(simp only: verund.simps lang.simps)
  by blast


lemma Lxx1: "xs  Lxx x y  length xs  2"
  apply(rule LxxI[where P="(λx y qs. length qs  2)"])
  apply(auto) by(auto simp: conc_def)

subsection "OPT2 Splitting"
         

lemma ayay: "length qs = length as  Tp s (qs@[q]) (as@[a]) = Tp s qs as + tp (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2) by simp_all

lemma tlofOPT2: "Q  {x,y}  set QS  {x,y}  R  {[x, y], [y, x]}  tl (OPT2 ((Q # QS) @ [x, x]) R) =
    OPT2 (QS @ [x, x]) (step R Q (hd (OPT2 ((Q # QS) @ [x, x]) R)))"
      apply(cases "Q=x")
        apply(cases "R=[x,y]")
          apply(simp add: OPT2x step_def)
          apply(simp)
            apply(cases QS)
                apply(simp add: step_def mtf2_def swap_def)
                apply(simp add: step_def mtf2_def swap_def)
        apply(cases "R=[x,y]")
          apply(simp)
            apply(cases QS)
                apply(simp add: step_def mtf2_def swap_def)
                apply(simp add: step_def mtf2_def swap_def)
          by(simp add: OPT2x step_def)


lemma Tp_split: "length qs1=length as1  Tp s (qs1@qs2) (as1@as2) = Tp s qs1 as1 + Tp (steps s qs1 as1) qs2 as2"
apply(induct qs1 as1 arbitrary: s rule: list_induct2) by(simp_all)
 
lemma Tp_spliting: "xy  set xs  {x,y}  set ys  {x,y} 
      R  {[x,y],[y,x]} 
      Tp R (xs@[x,x]) (OPT2 (xs@[x,x]) R) + Tp [x,y] ys (OPT2 ys [x,y])
      = Tp R (xs@[x,x]@ys) (OPT2 (xs@[x,x]@ys) R)"
proof -
  assume nxy: "xy"
  assume XSxy: "set xs  {x,y}"
  assume YSxy: "set ys  {x,y}"
  assume R: "R  {[x,y],[y,x]}"
  {
    fix R
    assume XSxy: "set xs  {x,y}"
    have "R{[x,y],[y,x]}  set xs  {x,y}   steps R (xs@[x,x]) (OPT2 (xs@[x,x]) R) = [x,y]"
    proof(induct xs arbitrary: R)
      case Nil
      then show ?case
        apply(cases "R=[x,y]")
(* FIXME why is simp_all needed? *)
          apply simp_all apply(simp add: step_def)
          by(simp add: step_def mtf2_def swap_def)
    next
      case (Cons Q QS)
      let ?R'="(step R Q (hd (OPT2 ((Q # QS) @ [x, x]) R)))"

      have a: "Q  {x,y}"  and b: "set QS  {x,y}" using Cons by auto 
      have t: "?R'  {[x,y],[y,x]}"
        apply(rule stepxy) using nxy Cons by auto
      then have "length (OPT2 (QS @ [x, x]) ?R') > 0" 
        apply(cases "?R' = [x,y]") by(simp_all add: OPT2_length)
      then have "OPT2 (QS @ [x, x]) ?R'  []" by auto
      then have hdtl: "OPT2 (QS @ [x, x]) ?R' = hd (OPT2 (QS @ [x, x]) ?R') # tl (OPT2 (QS @ [x, x]) ?R')" 
         by auto

      have maa: "(tl (OPT2 ((Q # QS) @ [x, x]) R)) = OPT2 (QS @ [x, x]) ?R' "
        using tlofOPT2[OF a b Cons(2)] by auto

      
      from Cons(2) have "length (OPT2 ((Q # QS) @ [x, x]) R) > 0" 
        apply(cases "R = [x,y]") by(simp_all add: OPT2_length)
      then have nempty: "OPT2 ((Q # QS) @ [x, x]) R  []" by auto
      then have "steps R ((Q # QS) @ [x, x]) (OPT2 ((Q # QS) @ [x, x]) R)
        = steps R ((Q # QS) @ [x, x]) (hd(OPT2 ((Q # QS) @ [x, x]) R) #  tl(OPT2 ((Q # QS) @ [x, x]) R))"
          by(simp)
      also have "    
        = steps ?R' (QS @ [x,x]) (tl (OPT2 ((Q # QS) @ [x, x]) R))"
          unfolding maa by auto
      also have " = steps ?R' (QS @ [x,x]) (OPT2 (QS @ [x, x]) ?R')" using maa by auto
      also with Cons(1)[OF t b] have " = [x,y]" by auto
      
        
      finally show ?case .
    qed
  } note aa=this

    from aa XSxy R have ll: "steps R (xs@[x,x]) (OPT2 (xs@[x,x]) R)
      = [x,y]" by auto

  have uer: " length (xs @ [x, x]) = length (OPT2 (xs @ [x, x]) R)"
    using R  by (auto simp: OPT2_length)

  have "OPT2 (xs @ [x, x] @ ys) R = OPT2 (xs @ [x, x]) R @ OPT2 ys [x, y]" 
    apply(rule OPT2_split11)
      using nxy XSxy YSxy R by auto


  then have "Tp R (xs@[x,x]@ys) (OPT2 (xs@[x,x]@ys) R)
        = Tp R ((xs@[x,x])@ys) (OPT2 (xs @ [x, x]) R @ OPT2 ys [x, y])"  by auto
  also have " = Tp R (xs@[x,x]) (OPT2 (xs @ [x, x]) R)
                + Tp [x,y] ys (OPT2 ys [x, y])"
                  using Tp_split[of "xs@[x,x]" "OPT2 (xs @ [x, x]) R" R ys "OPT2 ys [x, y]", OF uer, unfolded ll] 
                by auto
  finally show ?thesis by simp
qed


lemma OPTauseinander: "xy  set xs  {x,y}  set ys  {x,y} 
      LTS  {[x,y],[y,x]}  hd LTS = last xs 
     xs = (pref @ [hd LTS, hd LTS])  
      Tp [x,y] xs (OPT2 xs [x,y]) + Tp LTS ys (OPT2 ys LTS)
      = Tp [x,y] (xs@ys) (OPT2 (xs@ys) [x,y])"
proof -
  assume nxy: "xy"
  assume xsxy: "set xs  {x,y}"
  assume ysxy: "set ys  {x,y}"
  assume L: "LTS  {[x,y],[y,x]}"
  assume "hd LTS = last xs"
  assume prefix: "xs = (pref @ [hd LTS, hd LTS])"
  show ?thesis
    proof (cases "LTS = [x,y]")
      case True
      show ?thesis unfolding True prefix
        apply(simp)
        apply(rule Tp_spliting[simplified])
          using nxy xsxy ysxy prefix by auto
    next
      case False
      with L have TT: "LTS = [y,x]" by auto
      show ?thesis unfolding TT prefix
        apply(simp)
        apply(rule Tp_spliting[simplified])
          using nxy xsxy ysxy prefix by auto
   qed
qed


subsection "Phase Partitioning lemma"


theorem Phase_partitioning_general: 
  fixes P :: "(nat state * 'is) pmf  nat  nat list  bool"
      and A :: "(nat state,'is,nat,answer) alg_on_rand"
  assumes xny: "(x0::nat)  y0" 
    and cpos: "(c::real)0"
    and static: "set σ  {x0,y0}" 
    and initial: "P (map_pmf (%is. ([x0,y0],is)) (fst A [x0,y0])) x0 [x0,y0]"
    and D: "a b σ s.  σ  Lxx a b  ab  {a,b}={x0,y0}  P s a [x0,y0]   set σ  {a,b}
           T_on_rand' A s σ  c * Tp [a,b] σ (OPT2 σ [a,b])   P (config'_rand A s σ) (last σ) [x0,y0]"
  shows "Tp_on_rand A [x0,y0] σ   c * Tp_opt [x0,y0] σ + c"
proof -
  
 {
   fix x y s
 have "x  y  P s x [x0,y0]  set σ  {x,y}  {x,y}={x0,y0}  T_on_rand' A s σ  c * Tp [x,y] σ (OPT2 σ [x,y]) + c"
 proof (induction "length σ" arbitrary: σ x y s rule: less_induct)
  case (less σ) 

  show ?case
  proof (cases "xs ys. σ=xs@ys  xs  Lxx x y")
    case True 

    then obtain xs ys where qs: "σ=xs@ys" and xsLxx: "xs  Lxx x y" by auto

    with Lxx1 have len: "length ys < length σ" by fastforce
    from qs(1) less(4) have ysxy: "set ys  {x,y}" by auto

    have xsset: "set xs  {x, y}" using less(4) qs by auto
    from xsLxx Lxx1 have lxsgt1: "length xs  2" by auto
    then have xs_not_Nil: "xs  []" by auto

    from D[OF xsLxx less(2) less(5) less(3) xsset] 
      have D1: "T_on_rand' A s xs  c * Tp [x, y] xs (OPT2 xs [x, y])" 
         and inv: "P (config'_rand A s xs) (last xs) [x0, y0]" by auto
 

    from xsLxx Lxx_ends_in_two_equal obtain pref e where "xs = pref @ [e,e]" by metis
    then have endswithsame: "xs = pref @ [last xs, last xs]" by auto 

    let ?c' = "[last xs, other (last xs) x y]" 

    have setys: "set ys  {x,y}" using qs less by auto 
    have setxs: "set xs  {x,y}" using qs less by auto 
    have lxs: "last xs  set xs" using xs_not_Nil by auto
    from lxs setxs have lxsxy: "last xs  {x,y}" by auto 
     from lxs setxs have otherxy: "other (last xs) x y  {x,y}" by (simp add: other_def)
    from less(2) have other_diff: "last xs  other (last xs) x y" by(simp add: other_def)
 
    have lo: "{last xs, other (last xs) x y} = {x0, y0}"
      using lxsxy otherxy other_diff less(5) by force

    have nextstate: "{[last xs, other (last xs) x y], [other (last xs) x y, last xs]}
            = { [x,y],[y,x]}" using lxsxy otherxy other_diff by fastforce
    have setys': "set ys  {last xs, other (last xs) x y}"
            using setys lxsxy otherxy other_diff by fastforce
   
    have c: "T_on_rand' A (config'_rand A s xs) ys
         c * Tp ?c' ys (OPT2 ys ?c') + c"       
            apply(rule less(1))
              apply(fact len)
              apply(fact other_diff) 
              apply(fact inv) 
              apply(fact setys')
              by(fact lo)
 

    have well: "Tp [x, y] xs (OPT2 xs [x, y]) + Tp ?c' ys (OPT2 ys ?c')
        = Tp [x, y] (xs @ ys) (OPT2 (xs @ ys) [x, y])"
          apply(rule OPTauseinander[where pref=pref])
            apply(fact)+
            using lxsxy other_diff otherxy apply(fastforce)
            apply(simp)
            using endswithsame by simp  
      
    have E0: "T_on_rand' A s σ
          =  T_on_rand' A s (xs@ys)" using qs by auto
     also have E1: " = T_on_rand' A s xs + T_on_rand' A (config'_rand A s xs) ys"
              by (rule T_on_rand'_append)
    also have E2: "  T_on_rand' A s xs + c * Tp ?c' ys (OPT2 ys ?c') + c"
        using c by simp
    also have E3: "  c * Tp [x, y] xs (OPT2 xs [x, y]) + c * Tp ?c' ys (OPT2 ys ?c') + c"
        using D1 by simp        
    also have " = c * (Tp [x,y] xs (OPT2 xs [x,y]) + Tp ?c' ys (OPT2 ys ?c')) + c"
        using cpos apply(auto) by algebra
    also have  " = c * (Tp [x,y] (xs@ys) (OPT2 (xs@ys) [x,y])) + c"
      using well by auto 
    also have E4: " = c * (Tp [x,y] σ (OPT2 σ [x,y])) + c"
        using qs by auto
    finally show ?thesis .
  next
    case False
    note f1=this
    from Lxx_othercase[OF less(4) this, unfolded hideit_def] have
        nodouble: "σ = []  σ  lang (nodouble x y)" by  auto
    show ?thesis
    proof (cases "σ = []")
      case True
      then show ?thesis using cpos  by simp
    next
      case False
      (* with padding *)
      from False nodouble have qsnodouble: "σ  lang (nodouble x y)" by auto
      let ?padded = "pad σ x y"
      
      have padset: "set ?padded  {x, y}" using less(4) by(simp)

      from False pad_adds2[of σ x y] less(4) obtain addum where ui: "pad σ x y = σ @ [last σ]" by auto
      from nodouble_padded[OF False qsnodouble] have pLxx: "?padded  Lxx x y" .

      have E0: "T_on_rand' A s σ  T_on_rand' A s ?padded"
      proof -
        have "T_on_rand' A s σ = sum (T_on_rand'_n A s σ) {..<length σ}"
          by(rule T_on_rand'_as_sum)
        also have "
             = sum (T_on_rand'_n A s (σ @ [last σ])) {..<length σ}"
          proof(rule sum.cong, goal_cases)
            case (2 t)
            then have "t < length σ" by auto 
            then show ?case by(simp add: nth_append)
          qed simp
        also have "  T_on_rand' A s ?padded"
          unfolding ui
            apply(subst (2) T_on_rand'_as_sum) by(simp add: T_on_rand'_nn del: T_on_rand'.simps)  
        finally show ?thesis by auto
      qed  
 
      also have E1: "  c * Tp [x,y] ?padded (OPT2 ?padded [x,y])"
        using D[OF pLxx less(2) less(5) less(3) padset] by simp
      also have E2: "  c * (Tp [x,y] σ (OPT2 σ [x,y]) + 1)"
      proof -
        from False less(2) obtain σ' x' y' where qs': "σ = σ' @ [x']" and x': "x' = last σ" "y'x'" "y' {x,y}" 
            by (metis append_butlast_last_id insert_iff)
        have tla: "last σ  {x,y}" using less(4) False last_in_set by blast
        with x' have grgr: "{x,y} = {x',y'}" by auto
        then have "(x = x'  y = y')  (x = y'  y = x')" using less(2) by auto
        then have tts: "[x, y]  {[x', y'], [y', x']}" by blast
        
        from qs' ui have pd: "?padded = σ' @ [x', x']" by auto 

        have "Tp [x,y] (?padded) (OPT2 (?padded) [x,y])
              = Tp [x,y] (σ' @ [x', x']) (OPT2 (σ' @ [x', x']) [x,y])"
                unfolding pd by simp
        also have gr: "
             Tp [x,y] (σ' @ [x']) (OPT2 (σ' @ [x']) [x,y]) + 1"
              apply(rule OPT2_padded[where x="x'" and y="y'"])
                apply(fact)
                using grgr qs' less(4) by auto
        also have "  Tp [x,y] (σ) (OPT2 (σ) [x,y]) + 1" 
              unfolding qs' by simp
        finally show ?thesis using cpos by (meson mult_left_mono of_nat_le_iff)
      qed
      also have " =  c * Tp [x,y] σ (OPT2 σ [x,y]) + c" by (metis (no_types, lifting) mult.commute of_nat_1 of_nat_add semiring_normalization_rules(2))
      finally show ?thesis .  
    qed
  qed 
qed
} note allg=this  

 have "T_on_rand A [x0,y0] σ  c * real (Tp [x0, y0] σ (OPT2 σ [x0, y0])) + c"  
  apply(rule allg)
    apply(fact)
    using initial apply(simp add: map_pmf_def)
    apply(fact assms(3))
    by simp
  also have " = c * Tp_opt [x0, y0] σ + c"
    using OPT2_is_opt[OF assms(3,1)] by(simp)
  finally show ?thesis .
qed

term "A::(nat,'is) alg_on"

theorem Phase_partitioning_general_det: 
  fixes P :: "(nat state * 'is)  nat  nat list  bool"
      and A :: "(nat,'is) alg_on"
  assumes xny: "(x0::nat)  y0" 
    and cpos: "(c::real)0"
    and static: "set σ  {x0,y0}" 
    and initial: "P ([x0,y0],(fst A [x0,y0])) x0 [x0,y0]"
    and D: "a b σ s.  σ  Lxx a b  ab  {a,b}={x0,y0}  P s a [x0,y0]   set σ  {a,b}
           T_on' A s σ  c * Tp [a,b] σ (OPT2 σ [a,b])   P (config' A s σ) (last σ) [x0,y0]"
  shows "Tp_on A [x0,y0] σ   c * Tp_opt [x0,y0] σ + c"
proof -
  thm Phase_partitioning_general

  thm T_deter_rand
  term T_on'
  term "embed"
  show ?thesis oops



end

Theory List_Factoring

(*  Title:       List Factoring
    Author:      Max Haslbeck
*)

section "List factoring technique"

theory List_Factoring
imports
  Partial_Cost_Model
  MTF2_Effects
begin

hide_const config compet

subsection "Helper functions"

subsubsection "Helper lemmas"

lemma befaf: assumes "qset s" "distinct s"
shows "before q s  {q}  after q s = set s"
proof -
  have "before q s  {y. index s y = index s q  q  set s}
      = {y. index s y  index s q  q  set s}"
        unfolding before_in_def apply(auto) by (simp add: le_neq_implies_less)
  also have " =  {y. index s y  index s q  y set s  q  set s}"
    apply(auto) by (metis index_conv_size_if_notin index_less_size_conv not_less)
  also with q  set s have " = {y. index s y  index s q  y set s}" by auto
  finally have "before q s  {y. index s y = index s q  q  set s}  after q s
      = {y. index s y  index s q  y set s}  {y. index s y > index s q  y  set s}"
      unfolding before_in_def by simp
  also have " = set s" by auto
  finally show ?thesis using assms by simp
qed

lemma index_sum: assumes "distinct s" "qset s"
shows "index s q = (eset s. if e < q in s then 1 else 0)"
proof -
  from assms have bia_empty: "before q s  ({q}  after q s) = {}"
    by(auto simp: before_in_def)
  from befaf[OF assms(2) assms(1)] have "(eset s. if e < q in s then 1::nat else 0)
    = (e(before q s  {q}  after q s). if e < q in s then 1 else 0)" by auto
  also have " = (ebefore q s. if e < q in s then 1 else 0)
            + (e{q}. if e < q in s then 1 else 0) + (eafter q s. if e < q in s then 1 else 0)"
   proof -
      have "(e(before q s  {q}  after q s). if e < q in s then 1::nat else 0)
      = (e(before q s  ({q}  after q s)). if e < q in s then 1::nat else 0)"
        by simp
      also have " = (ebefore q s. if e < q in s then 1 else 0)
          + (e({q}  after q s). if e < q in s then 1 else 0)
          - (e(before q s  ({q}  after q s)). if e < q in s then 1 else 0)"
          apply(rule sum_Un_nat) by(simp_all)
      also have " = (ebefore q s. if e < q in s then 1 else 0)
          + (e({q}  after q s). if e < q in s then 1 else 0)" using bia_empty by auto
      also have " = (ebefore q s. if e < q in s then 1 else 0)
          + (e{q}. if e < q in s then 1 else 0) + (eafter q s. if e < q in s then 1 else 0)"
          by (simp add: before_in_def)
      finally show ?thesis .
    qed
  also have " = (ebefore q s. 1) + (e({q}  after q s). 0)" apply(auto)
    unfolding before_in_def by auto
  also have " = card (before q s)" by auto
  also have " = card (set (take (index s q) s))" using before_conv_take[OF assms(2)] by simp
  also have " = length (take (index s q) s)" using distinct_card assms(1) distinct_take by metis
  also have " = min (length s) (index s q)" by simp
  also have " = index s q" using index_le_size[of s q] by(auto)
  finally show ?thesis by simp
qed


subsubsection "ALG"

fun ALG :: "'a  'a list  nat  ('a list * 'is)  nat" where
  "ALG x qs i s = (if x < (qs!i) in fst s then 1::nat else 0)" 

(* no paid exchanges, requested items in state (nice, quickcheck is awesome!) *)
lemma tp_sumofALG: "distinct (fst s)  snd a = []  (qs!i)set (fst s) 
     tp (fst s) (qs!i) a = (eset (fst s). ALG e qs i s)"
unfolding tp_def apply(simp add: split_def )
  using index_sum by metis

lemma tp_sumofALGreal: assumes "distinct (fst s)" "snd a = []" "qs!i  set(fst s)" 
shows "real(tp (fst s) (qs!i) a) = (eset (fst s). real(ALG e qs i s))"
proof -
  from assms have "real(tp (fst s) (qs!i) a) = real(eset (fst s). ALG e qs i s)"
    using tp_sumofALG by metis
  also have " = (eset (fst s). real (ALG e qs i s))"
    by auto
  finally show ?thesis .
qed


subsubsection "The function steps'"

fun steps' where
  "steps' s _ _ 0 = s"
| "steps' s [] [] (Suc n) = s"
| "steps' s (q#qs) (a#as) (Suc n) = steps' (step s q a) qs as n"

lemma steps'_steps: "length as = length qs  steps' s as qs (length as) = steps s as qs"
by(induct arbitrary: s rule: list_induct2, simp_all)


lemma steps'_length: "length qs = length as  n  length as
   length (steps' s qs as n) = length s"
apply(induct qs as arbitrary: s  n rule: list_induct2)
  apply(simp)
  apply(case_tac n)
    by (auto)

lemma steps'_set: "length qs = length as  n  length as
   set (steps' s qs as n) = set s"
apply(induct qs as arbitrary: s  n rule: list_induct2)
  apply(simp)
  apply(case_tac n)
    by(auto simp: set_step)

lemma steps'_distinct2: "length qs = length as  n  length as
    distinct s  distinct (steps' s qs as n)"
apply(induct qs as arbitrary: s  n rule: list_induct2)
  apply(simp)
  apply(case_tac n)
    by(auto simp: distinct_step)


lemma steps'_distinct: "length qs = length as  length as = n
   distinct (steps' s qs as n) = distinct s"
  by (induct qs as arbitrary: s n rule: list_induct2) (fastforce simp add: distinct_step)+

lemma steps'_dist_perm: "length qs = length as  length as = n
   dist_perm s s  dist_perm (steps' s qs as n) (steps' s qs as n)"
using steps'_set steps'_distinct by blast

lemma steps'_rests: "length qs = length as  n  length as  steps' s qs as n = steps' s (qs@r1) (as@r2) n" 
apply(induct qs as arbitrary: s  n rule: list_induct2)
  apply(simp) apply(case_tac n) by auto

lemma steps'_append: "length qs = length as  length qs = n  steps' s (qs@[q]) (as@[a]) (Suc n) = step (steps' s qs as n) q a"
apply(induct qs as arbitrary: s  n rule: list_induct2) by auto

subsubsection "ALG'_det›"

definition "ALG'_det Strat qs init i x = ALG x qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),())"

lemma ALG'_det_append: "n < length Strat  n < length qs  ALG'_det Strat (qs@a) init n x 
                        = ALG'_det Strat qs init n x"
proof -
  assume qs: "n < length qs"
  assume S: "n < length Strat"

  have tt: "(qs @ a) ! n = qs ! n"
    using qs by (simp add: nth_append)

  have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ drop n qs) ((take n Strat) @ (drop n Strat)) n"
       apply(rule steps'_rests)
        using S qs by auto
  then have A: "steps' init (take n qs) (take n Strat) n = steps' init qs Strat n" by auto
  have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ ((drop n qs)@a)) ((take n Strat) @((drop n Strat)@[])) n"
       apply(rule steps'_rests)
        using S qs by auto
  then have B: "steps' init (take n qs) (take n Strat) n = steps' init (qs@a) (Strat@[]) n"
    by (metis append_assoc List.append_take_drop_id)
  from A B have "steps' init qs Strat n = steps' init (qs@a) (Strat@[]) n" by auto
  then have C: "steps' init qs Strat n = steps' init (qs@a) Strat n" by auto

  show ?thesis unfolding ALG'_det_def C
      unfolding ALG.simps tt by auto
qed 

subsubsection "ALG'"

abbreviation "config'' A qs init n == config_rand A init (take n qs)"

definition "ALG' A qs init i x = E( map_pmf (ALG x qs i) (config'' A qs init i))"

lemma ALG'_refl: "qs!i = x  ALG' A qs init i x = 0"
unfolding ALG'_def by(simp add: split_def before_in_def)
 
subsubsection "ALGxy_det›"

definition ALGxy_det where
  "ALGxy_det A qs init x y = (i{..<length qs}. (if (qs!i  {y,x}) then ALG'_det A qs init i y + ALG'_det A qs init i x
                                                    else 0::nat))"

lemma ALGxy_det_alternativ: "ALGxy_det A qs init x y
   =  (i{i. i<length qs  (qs!i  {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)"
proof -
  have f: "{i. i<length qs} = {..<length qs}" by(auto)

  have e: "{i. i<length qs  (qs!i  {y,x})} = {i. i<length qs}  {i. (qs!i  {y,x})}"
      by auto
  have "(i{i. i<length qs  (qs!i  {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)
    = (i{i. i<length qs}  {i. (qs!i  {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)"
    unfolding e by simp
  also have " = (i{i. i<length qs}. (if i  {i. (qs!i  {y,x})} then ALG'_det A qs init i y + ALG'_det A qs init i x
                                                    else 0))"
    apply(rule sum.inter_restrict) by auto
  also have " = (i{..<length qs}. (if i  {i. (qs!i  {y,x})} then ALG'_det A qs init i y + ALG'_det A qs init i x
                                                    else 0))"
      unfolding f by auto
  also have " = ALGxy_det A qs init x y"
    unfolding ALGxy_det_def by auto
  finally show ?thesis by simp
qed
    
subsubsection "ALGxy"

definition ALGxy where
  "ALGxy A qs init x y = (i{..<length qs}  {i. (qs!i  {y,x})}. ALG' A qs init i y + ALG' A qs init i x)"

lemma ALGxy_def2:
  "ALGxy A qs init x y = (i{i. i<length qs  (qs!i  {y,x})}. ALG' A qs init i y + ALG' A qs init i x)"
proof -
  have a: "{i. i<length qs  (qs!i  {y,x})} = {..<length qs}  {i. (qs!i  {y,x})}" by auto
  show ?thesis unfolding ALGxy_def a by simp
qed
lemma ALGxy_append: "ALGxy A (rs@[r]) init x y =
      ALGxy A rs init x y + (if (r  {y,x}) then ALG' A (rs@[r]) init (length rs) y + ALG' A (rs@[r]) init (length rs) x else 0 )" 
proof -
    have "ALGxy A (rs@[r]) init x y = (i{..<(Suc (length rs))}  {i. (rs @ [r]) ! i  {y, x}}.
       ALG' A (rs @ [r]) init i y +
       ALG' A (rs @ [r]) init i x)" unfolding ALGxy_def by(simp)
    also have " = (i{..<(Suc (length rs))}. (if i{i. (rs @ [r]) ! i  {y, x}} then
       ALG' A (rs @ [r]) init i y +
       ALG' A (rs @ [r]) init i x else 0) )"
       apply(rule sum.inter_restrict) by simp
    also have " = (i{..<length rs}. (if i{i. (rs @ [r]) ! i  {y, x}} then
       ALG' A (rs @ [r]) init i y +
       ALG' A (rs @ [r]) init i x else 0) ) + (if length rs{i. (rs @ [r]) ! i  {y, x}} then
       ALG' A (rs @ [r]) init (length rs) y +
       ALG' A (rs @ [r]) init(length rs) x else 0) " by simp
    also have " = ALGxy A rs init x y + (if r  {y, x} then
       ALG' A (rs @ [r]) init (length rs) y +
       ALG' A (rs @ [r]) init(length rs) x else 0)" 
            apply(simp add: ALGxy_def sum.inter_restrict nth_append)
            unfolding ALG'_def
              apply(rule sum.cong)
                apply(simp)  by(auto simp: nth_append)
    finally show ?thesis .
qed

lemma ALGxy_wholerange: "ALGxy A qs init x y
    = (i<(length qs). (if qs ! i  {y, x}
          then ALG' A qs init i y + ALG' A qs init i x
          else 0 ))"
proof -
  have "ALGxy A qs init x y
      = (i {i. i < length qs}  {i. qs ! i  {y, x}}.
       ALG' A qs init i y + ALG' A qs init i x)"
        unfolding ALGxy_def
        apply(rule sum.cong)
          apply(simp) apply(blast) 
          by simp 
  also have " = (i{i. i < length qs}.  if i  {i. qs ! i  {y, x}}
                                    then ALG' A qs init i y + ALG' A qs init i x 
                                    else 0)"
              by(rule sum.inter_restrict) simp
  also have " = (i<(length qs). (if qs ! i  {y, x}
          then ALG' A qs init i y + ALG' A qs init i x
          else 0 ))" apply(rule sum.cong) by(auto)
  finally show ?thesis .
qed
  
subsection "Transformation to Blocking Cost"

lemma umformung:
  fixes A :: "(('a::linorder) list,'is,'a,(nat * nat list)) alg_on_rand"
  assumes no_paid: "is s q. ((free,paid),_)  (snd A (s,is) q). paid=[]"
  assumes inlist: "set qs  set init"
  assumes dist: "distinct init"
  assumes "x. x < length qs  finite (set_pmf (config'' A qs init x))"
  shows "Tp_on_rand A init qs = 
    ((x,y){(x,y). x  set init  yset init  x<y}. ALGxy A qs init x y)"
proof -
  have config_dist: "n. xa  set_pmf (config'' A qs init n). distinct (fst xa)"
      using dist config_rand_distinct by metis

  have E0: "Tp_on_rand A init qs =
        (i{..<length qs}. Tp_on_rand_n A init qs i)" unfolding T_on_rand_as_sum by auto
  also have " = 
  (i<length qs.  E (bind_pmf (config'' A qs init i)
                          (λs. bind_pmf (snd A s (qs ! i))
                            (λ(a, nis). return_pmf (real (xset init. ALG x qs i s))))))"
    apply(rule sum.cong)
      apply(simp)
      apply(simp add: bind_return_pmf bind_assoc_pmf)
      apply(rule arg_cong[where f=E]) 
          apply(rule bind_pmf_cong)
            apply(simp)
              apply(rule bind_pmf_cong)
                apply(simp)
                apply(simp add: split_def)
                  apply(subst tp_sumofALGreal)
                  proof (goal_cases)
                    case 1
                    then show ?case using config_dist by(metis)
                  next
                    case (2 a b c)
                    then show ?case using no_paid[of "fst b" "snd b"] by(auto simp add: split_def)
                  next
                    case (3 a b c)
                    with config_rand_set have a: "set (fst b) = set init" by metis
                    with inlist have " set qs  set (fst b)" by auto
                    with 3 show ?case by auto 
                  next
                    case (4 a b c)
                    with config_rand_set have a: "set (fst b) = set init" by metis
                    then show ?case by(simp) 
                  qed
          

          (* hier erst s, dann init *)
   also have " = (i<length qs.
               E (map_pmf (λ(is, s). (real (xset init. ALG x qs i (is,s))))
                           (config'' A qs init i)))" 
                   apply(simp only: map_pmf_def split_def) by simp 
   also have E1: " = (i<length qs. (xset init. ALG' A qs init i x))"
        apply(rule sum.cong)
          apply(simp) 
            apply(simp add: split_def ALG'_def)
             apply(rule E_linear_sum_allg)
              by(rule assms(4)) 
   also have E2: " = (xset init.
          (i<length qs. ALG' A qs init i x))"
          by(rule sum.swap) (* die summen tauschen *)
   also have E3: " = (xset init.
          (yset init.
            (i{i. i<length qs  qs!i=y}. ALG' A qs init i x)))"
            proof (rule sum.cong, goal_cases)
              case (2 x)
              have "(i<length qs. ALG' A qs init i x)
                = sum (%i. ALG' A qs init i x) {i. i<length qs}"
                  by (metis lessThan_def)
              also have " = sum (%i. ALG' A qs init i x) 
                        (y{y. y  set init}. {i. i < length qs  qs ! i = y})"
                         apply(rule sum.cong)
                          apply(auto)
                         using inlist by auto
              also have " = sum (%t. sum (%i. ALG' A qs init i x) {i. i<length qs  qs ! i = t}) {y. y set init}"
                apply(rule sum.UNION_disjoint)
                  apply(simp_all) by force
              also have " = (yset init. i | i < length qs  qs ! i = y.
                       ALG' A qs init i x)" by auto                  
             finally show ?case .
            qed (simp)
              
   also have " = ((x,y) (set init × set init).
            (i{i. i<length qs  qs!i=y}. ALG' A qs init i x))"
       by (rule sum.cartesian_product)
   also have " = ((x,y) {(x,y). xset init  y set init}.
            (i{i. i<length qs  qs!i=y}. ALG' A qs init i x))"
            by simp
    also have E4: " = ((x,y){(x,y). xset init  y set init  xy}.
            (i{i. i<length qs  qs!i=y}. ALG' A qs init i x))" (is "((x,y) ?L. ?f x y) = ((x,y) ?R. ?f x y)")
      proof -
        let ?M = "{(x,y). xset init  y set init  x=y}"
        have A: "?L = ?R  ?M" by auto
        have B: "{} = ?R  ?M" by auto

        have "((x,y) ?L. ?f x y) = ((x,y) ?R  ?M. ?f x y)"
          by(simp only: A)
        also have " = ((x,y) ?R. ?f x y) + ((x,y) ?M. ?f x y)"
            apply(rule sum.union_disjoint)
              apply(rule finite_subset[where B="set init × set init"])
                apply(auto)
              apply(rule finite_subset[where B="set init × set init"])
                by(auto)
        also have "((x,y) ?M. ?f x y) = 0"
          apply(rule sum.neutral)
            by (auto simp add: ALG'_refl) 
        finally show ?thesis by simp
      qed

   also have " = ((x,y){(x,y). x  set init  yset init  x<y}.
            (i{i. i<length qs  qs!i=y}. ALG' A qs init i x)
           + (i{i. i<length qs  qs!i=x}. ALG' A qs init i y) )"
            (is "((x,y) ?L. ?f x y) = ((x,y) ?R. ?f x y +  ?f y x)")
              proof -
                let ?R' = "{(x,y). x  set init  yset init  y<x}"
                have A: "?L = ?R  ?R'" by auto
                have "{} = ?R  ?R'" by auto
                have C: "?R' = (%(x,y). (y, x)) ` ?R" by auto

                have D: "((x,y) ?R'. ?f x y) = ((x,y) ?R. ?f y x)"
                proof -
                  have "((x,y) ?R'. ?f x y) = ((x,y) (%(x,y). (y, x)) ` ?R. ?f x y)"
                      by(simp only: C)
                  also have "(z (%(x,y). (y, x)) ` ?R. (%(x,y). ?f x y) z) = (z?R. ((%(x,y). ?f x y)  (%(x,y). (y, x))) z)"
                    apply(rule sum.reindex)
                      by(fact swap_inj_on)
                  also have " = (z?R. (%(x,y). ?f y x) z)"
                    apply(rule sum.cong)
                      by(auto)
                  finally show ?thesis .                  
              qed

                have "((x,y) ?L. ?f x y) = ((x,y) ?R  ?R'. ?f x y)"
                  by(simp only: A) 
                also have " = ((x,y) ?R. ?f x y) + ((x,y) ?R'. ?f x y)"
                  apply(rule sum.union_disjoint) 
                    apply(rule finite_subset[where B="set init × set init"])
                      apply(auto)
                    apply(rule finite_subset[where B="set init × set init"])
                      by(auto)
                also have " = ((x,y) ?R. ?f x y) + ((x,y) ?R. ?f y x)"
                    by(simp only: D)                  
                also have " = ((x,y) ?R. ?f x y + ?f y x)"
                  by(simp add: split_def sum.distrib[symmetric])
              finally show ?thesis .
            qed
                
   also have E5: " = ((x,y){(x,y). x  set init  yset init  x<y}.
            (i{i. i<length qs  (qs!i=y  qs!i=x)}. ALG' A qs init i y + ALG' A qs init i x))"
    apply(rule sum.cong)
      apply(simp)
      proof goal_cases
        case (1 x)
        then obtain a b where x: "x=(a,b)" and a: "a  set init" "b  set init" "a < b" by auto
        then have "ab" by simp
        then have disj: "{i. i < length qs  qs ! i = b}  {i. i < length qs  qs ! i = a} = {}" by auto
        have unio: "{i. i < length qs  (qs ! i = b  qs ! i = a)}
            = {i. i < length qs  qs ! i = b}  {i. i < length qs  qs ! i = a}" by auto
        have "(i{i. i < length qs  qs ! i = b} 
          {i. i < length qs  qs ! i = a}. ALG' A qs init i b +
               ALG' A qs init i a)
               = (i{i. i < length qs  qs ! i = b}. ALG' A qs init i b +
               ALG' A qs init i a) + (i
          {i. i < length qs  qs ! i = a}. ALG' A qs init i b +
               ALG' A qs init i a) - (i{i. i < length qs  qs ! i = b} 
          {i. i < length qs  qs ! i = a}. ALG' A qs init i b +
               ALG' A qs init i a) "
               apply(rule sum_Un)
                by(auto)
        also have " = (i{i. i < length qs  qs ! i = b}. ALG' A qs init i b +
               ALG' A qs init i a) + (i
          {i. i < length qs  qs ! i = a}. ALG' A qs init i b +
               ALG' A qs init i a)" using disj by auto
        also have " = (i{i. i < length qs  qs ! i = b}. ALG' A qs init i a)
         + (i{i. i < length qs  qs ! i = a}. ALG' A qs init i b)"
          by (auto simp: ALG'_refl)
        finally 
            show ?case unfolding x apply(simp add: split_def)
          unfolding unio by simp
     qed   
     also have E6: " = ((x,y){(x,y). x  set init  yset init  x<y}.
                  ALGxy A qs init x y)"
           unfolding ALGxy_def2 by simp
     finally show ?thesis . 
qed (* this is lemma 1.4 *)


lemma before_in_index1:
  fixes l
  assumes "set l = {x,y}" and "length l = 2" and "xy"
  shows "(if (x < y in l) then 0 else 1) = index l x"
unfolding before_in_def
proof (auto, goal_cases) (* bad style! *)
  case 1
  from assms(1) have "index l y < length l" by simp
  with assms(2) 1(1) show "index l x = 0" by auto
next
  case 2
  from assms(1) have a: "index l x < length l" by simp
  from assms(1,3) have "index l y  index l x" by simp
  with assms(2) 2(1) a show "Suc 0 = index l x" by simp
qed (simp add: assms)


lemma before_in_index2:
  fixes l
  assumes "set l = {x,y}" and "length l = 2" and "xy"
  shows "(if (x < y in l) then 1 else 0) = index l y"
unfolding before_in_def
proof (auto, goal_cases) (* bad style! *)
  case 2
  from assms(1,3) have a: "index l y  index l x" by simp
  from assms(1) have "index l x < length l" by simp
  with assms(2) a 2(1) show "index l y = 0" by auto
next
  case 1
  from assms(1) have a: "index l y < length l" by simp
  from assms(1,3) have "index l y  index l x" by simp
  with assms(2) 1(1) a show "Suc 0 = index l y" by simp
qed (simp add: assms)


lemma before_in_index:
  fixes l
  assumes "set l = {x,y}" and "length l = 2" and "xy"
  shows "(x < y in l) = (index l x = 0)"
unfolding before_in_def
proof (safe, goal_cases)
  case 1
  from assms(1) have "index l y < length l" by simp
  with assms(2) 1(1) show "index l x = 0" by auto
next
  case 2
  from assms(1,3) have "index l y  index l x" by simp
  with 2(1) show "index l x < index l y" by simp
qed (simp add: assms)


subsection "The pairwise property"


definition pairwise where
  "pairwise A = (init. distinct init  (qs{xs. set xs  set init}. (x::('a::linorder),y){(x,y). x  set init  yset init  x<y}. Tp_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}) = ALGxy A qs init x y))"
  
definition "Pbefore_in x y A qs init = map_pmf (λp. x < y in fst p) (config_rand A init qs)"
 

lemma T_on_n_no_paid:
      assumes 
      nopaid: "s n. map_pmf (λx. snd (fst x)) (snd A s n) = return_pmf []" 
      shows "T_on_rand_n A init qs i = E (config'' A qs init i  (λp. return_pmf (real(index (fst p) (qs ! i)))))"
proof - 

  have "(λs. snd A s (qs ! i) 
            (λ(a, is'). return_pmf (real (tp (fst s) (qs ! i) a))))
       =
        (λs. (snd A s (qs ! i)  (λx. return_pmf (snd (fst x))))
               (λp. return_pmf
               (real (index (swaps p (fst s)) (qs ! i)) +
                real (length p))))"
            by(simp add: tp_def split_def bind_return_pmf bind_assoc_pmf)
also
  have " = (λp. return_pmf (real (index (fst p) (qs ! i))))"
    using nopaid[unfolded map_pmf_def]
    by(simp add: split_def bind_return_pmf)
finally
  show ?thesis by simp
qed
 
lemma pairwise_property_lemma:
  assumes  
relativeorder: "(init qs. distinct init  qs  {xs. set xs  set init}
     (x y. (x,y) {(x,y). x  set init  yset init  xy} 
                 x  y
                 Pbefore_in x y A qs init = Pbefore_in x y A (Lxy qs {x,y}) (Lxy init {x,y})
        ))" 
and nopaid: "xa r. z set_pmf(snd A xa r). snd(fst z) = []"
shows "pairwise A"
unfolding pairwise_def
proof (clarify, goal_cases)
  case (1 init rs x y)
  then have xny: "xy" by auto

  note dinit=1(1)
  then have dLyx: "distinct (Lxy init {y,x})" by(rule Lxy_distinct)
  from dinit have dLxy: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)
  have setLxy: "set (Lxy init {x, y}) = {x,y}" apply(subst Lxy_set_filter) using 1 by auto
  have setLyx: "set (Lxy init {y, x}) = {x,y}" apply(subst Lxy_set_filter) using 1 by auto
  have lengthLyx:" length  (Lxy init {y, x}) = 2" using setLyx distinct_card[OF dLyx] xny by simp
  have lengthLxy:" length  (Lxy init {x, y}) = 2" using setLxy distinct_card[OF dLxy] xny by simp
  have aee: "{x,y} = {y,x}" by auto


  from 1(2) show ?case
    proof(induct rs rule: rev_induct)
      case (snoc r rs)
      
      have b: "Pbefore_in x y A rs init = Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y})"
        apply(rule relativeorder)
        using snoc 1 xny by(simp_all)  

      show ?case (is "?L (rs @ [r]) = ?R (rs @ [r])")
      proof(cases "r{x,y}")
        case True
        note xyrequest=this
        let ?expr = "E (Partial_Cost_Model.config'_rand A
        (fst A (Lxy init {x, y}) 
         (λis. return_pmf (Lxy init {x, y}, is)))
        (Lxy rs {x, y}) 
       (λs. snd A s r 
            (λ(a, is').
                return_pmf
                 (real (tp (fst s) r a)))))"
        let ?expr2 = "ALG' A (rs @ [r]) init (length rs) y + ALG' A (rs @ [r]) init (length rs) x"

        from xyrequest have "?L (rs @ [r]) = ?L rs + ?expr"
          by(simp add: Lxy_snoc T_on_rand'_append)
        also have " = ?L rs + ?expr2"
          proof(cases "r=x") 
            case True
            let ?projS ="config'_rand A (fst A (Lxy init {x, y})  (λis. return_pmf (Lxy init {x, y}, is))) (Lxy rs {x, y})"
            let ?S = "(config'_rand A (fst A init  (λis. return_pmf (init, is))) rs)"


            have "?projS  (λs. snd A s r
                            (λ(a, is'). return_pmf (real (tp (fst s) r a))))
              = ?projS  (λs. return_pmf (real (index (fst s) r)))"
                    proof (rule bind_pmf_cong, goal_cases)
                      case (2 z)
                      have "snd A z r  (λ(a, is'). return_pmf (real (tp (fst z) r a))) = snd A z r  (λx. return_pmf (real (index (fst z) r)))"  
                        apply(rule bind_pmf_cong)
                          apply(simp)
                          using nopaid[of z r] by(simp add: split_def tp_def) 
                      then show ?case by(simp add: bind_return_pmf)
                    qed simp
            also have " = map_pmf (%b. (if b then 0::real else 1)) (Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y}))"
                  unfolding Pbefore_in_def map_pmf_def
                    apply(simp add: bind_return_pmf bind_assoc_pmf)
                    apply(rule bind_pmf_cong)
                      apply(simp add: aee)
                      proof goal_cases
                        case (1 z)
                        have " (if x < y in fst z then 0 else 1) = (index (fst z) x)"
                            apply(rule before_in_index1)
                              using 1 config_rand_set setLxy apply fast
                              using 1 config_rand_length lengthLxy apply metis                 
                              using xny by simp
                        with True show ?case
                          by(auto)
                      qed
            also have " = map_pmf (%b. (if b then 0::real else 1)) (Pbefore_in x y A rs init)" by(simp add: b)
                      
            also have " = map_pmf (λxa. real (if y < x in fst xa then 1 else 0)) ?S"  
                apply(simp add: Pbefore_in_def map_pmf_comp)
                proof (rule map_pmf_cong, goal_cases)
                  case (2 z)
                  then have set_z: "set (fst z) = set init"
                    using config_rand_set by fast
                  have "(¬ x < y in fst z) = y < x in fst z" 
                    apply(subst not_before_in)
                      using set_z 1(3,4) xny by(simp_all)
                  then show ?case by(simp add: )
                qed simp 
            finally have a: "?projS  (λs. snd A s x
                            (λ(a, is'). return_pmf (real (tp (fst s) x a))))
                  = map_pmf (λxa. real (if y < x in fst xa then 1 else 0)) ?S" using True by simp
            from True show ?thesis
            apply(simp add: ALG'_refl nth_append)
            unfolding ALG'_def
              by(simp add: a)
          next
            case False
            with xyrequest have request: "r=y" by blast

            let ?projS ="config'_rand A (fst A (Lxy init {x, y})  (λis. return_pmf (Lxy init {x, y}, is))) (Lxy rs {x, y})"
            let ?S = "(config'_rand A (fst A init  (λis. return_pmf (init, is))) rs)"


            have "?projS  (λs. snd A s r
                            (λ(a, is'). return_pmf (real (tp (fst s) r a))))
              = ?projS  (λs. return_pmf (real (index (fst s) r)))"
                    proof (rule bind_pmf_cong, goal_cases)
                      case (2 z)
                      have "snd A z r  (λ(a, is'). return_pmf (real (tp (fst z) r a))) = snd A z r  (λx. return_pmf (real (index (fst z) r)))"  
                        apply(rule bind_pmf_cong)
                          apply(simp)
                          using nopaid[of z r] by(simp add: split_def tp_def) 
                      then show ?case by(simp add: bind_return_pmf)
                    qed simp
            also have " = map_pmf (%b. (if b then 1::real else 0)) (Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y}))"
                  unfolding Pbefore_in_def map_pmf_def
                    apply(simp add: bind_return_pmf bind_assoc_pmf)
                    apply(rule bind_pmf_cong)
                      apply(simp add: aee)
                      proof goal_cases
                        case (1 z)
                        have " (if x < y in fst z then 1 else 0) = (index (fst z) y)"
                            apply(rule before_in_index2)
                              using 1 config_rand_set setLxy apply fast
                              using 1 config_rand_length lengthLxy apply metis                 
                              using xny by simp
                        with request show ?case
                          by(auto)
                      qed
            also have " = map_pmf (%b. (if b then 1::real else 0)) (Pbefore_in x y A rs init)" by(simp add: b)
                      
            also have " = map_pmf (λxa. real (if x < y in fst xa then 1 else 0)) ?S"  
                apply(simp add: Pbefore_in_def map_pmf_comp)
                apply (rule map_pmf_cong) by simp_all 
            finally have a: "?projS  (λs. snd A s y
                            (λ(a, is'). return_pmf (real (tp (fst s) y a))))
                  = map_pmf (λxa. real (if x < y in fst xa then 1 else 0)) ?S" using request by simp
            from request show ?thesis
            apply(simp add: ALG'_refl nth_append)
            unfolding ALG'_def
              by(simp add: a) 
          qed            
        also have " = ?R rs + ?expr2" using snoc by simp 
        also from True have " = ?R (rs@[r])"
            apply(subst ALGxy_append) by(auto)
        finally show ?thesis .
      next
        case False
        then have "?L (rs @ [r]) = ?L rs" apply(subst Lxy_snoc) by simp
        also have " = ?R rs" using snoc by(simp)
        also have " = ?R (rs @ [r])"  
            apply(subst ALGxy_append) using False by(simp)
        finally show ?thesis .
      qed
    qed (simp add: ALGxy_def)
qed


lemma umf_pair: assumes
   0: "pairwise A"
  assumes 1: "is s q. ((free,paid),_)  (snd A (s, is) q). paid=[]"
  assumes 2: "set qs  set init"
  assumes 3: "distinct init"
  assumes 4: "x. x<length qs  finite (set_pmf (config'' A qs init x))"
   shows "Tp_on_rand A init qs
      = ((x,y){(x, y). x  set init  y  set init  x < y}. Tp_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}))"
proof -
  have " Tp_on_rand A init qs = ((x,y){(x, y). x  set init  y  set init  x < y}. ALGxy A qs init x y)"
    by(simp only: umformung[OF 1 2 3 4])
  also have " = ((x,y){(x, y). x  set init  y  set init  x < y}. Tp_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}))"
    apply(rule sum.cong)
      apply(simp)
      using 0[unfolded pairwise_def] 2 3 by auto
  finally show ?thesis .
qed
 
subsection "List Factoring for OPT"

(* calculates given a list of swaps, elements x and y and a current state
  how many swaps between x and y there are *)
fun ALG_P :: "nat list  'a   'a   'a list  nat" where
  "ALG_P [] x y xs = (0::nat)"
| "ALG_P (s#ss) x y xs = (if Suc s < length (swaps ss xs)
                          then (if ((swaps ss xs)!s=x  (swaps ss xs)!(Suc s)=y)  ((swaps ss xs)!s=y  (swaps ss xs)!(Suc s)=x)
                                then 1
                                else 0)
                          else 0) + ALG_P ss x y xs"

(* nat list ersetzen durch (a::ordered) list *)
lemma ALG_P_erwischt_alle:
  assumes dinit: "distinct init" 
  shows
  "l< length sws. Suc (sws!l) < length init  length sws
        = ((x,y){(x,y). x  set (init::('a::linorder) list)  yset init  x<y}. ALG_P sws x y init)"
proof (induct sws)
  case (Cons s ss)
  then have isininit: "Suc s < length init" by auto
  from Cons have "l<length ss. Suc (ss ! l)  < length init" by auto
  note iH=Cons(1)[OF this]
  
  let ?expr = "(λx y. (if Suc s < length (swaps ss init)
                          then (if ((swaps ss init)!s=x  (swaps ss init)!(Suc s)=y)  ((swaps ss init)!s=y  (swaps ss init)!(Suc s)=x)
                                then 1::nat
                                else 0)
                          else 0))"

  let ?expr2 = "(λx y. (if ((swaps ss init)!s=x  (swaps ss init)!(Suc s)=y)  ((swaps ss init)!s=y  (swaps ss init)!(Suc s)=x)
                                then 1
                                else 0))"

  let ?expr3 = "(%x y.  ((swaps ss init)!s=x  (swaps ss init)!(Suc s)=y)
                     ((swaps ss init)!s=y  (swaps ss init)!(Suc s)=x))"
  let ?co' = "swaps ss init"

  from dinit have dco: "distinct ?co'" by auto

  let ?expr4 = "(λz. (if z{(x,y). ?expr3 x y}
                                then 1
                                else 0))"

  have scoinit: "set ?co' = set init" by auto
  from isininit have isT: "Suc s < length ?co'" by auto
  then have isT2: "Suc s < length init" by auto
  then have isT3: "s < length init" by auto
  then have isT6: "s < length ?co'" by auto
  from isT2 have isT7: "Suc s < length ?co'" by auto
  from isT6 have a: "?co'!s  set ?co'" by (rule nth_mem)
  then have a: "?co'!s  set init" by auto
  from isT7 have "?co'! (Suc s)  set ?co'" by (rule nth_mem)
  then have b: "?co'!(Suc s)  set init" by auto

  have  "{(x,y). x  set init  yset init  x<y}
                           {(x,y). ?expr3 x y}
     = {(x,y). x  set init  yset init  x<y
                                (?co'!s=x  ?co'!(Suc s)=y
                                   ?co'!s=y  ?co'!(Suc s)=x)}" by auto
  also have " = {(x,y). x  set init  yset init  x<y
                                ?co'!s=x  ?co'!(Suc s)=y }
                           
                  {(x,y). x  set init  yset init  x<y
                                 ?co'!s=y  ?co'!(Suc s)=x}" by auto
  also have " = {(x,y). x<y  ?co'!s=x  ?co'!(Suc s)=y}
                           
                  {(x,y). x<y  ?co'!s=y  ?co'!(Suc s)=x}"
              using a b by(auto)
  finally have c1: "{(x,y). x  set init  yset init  x<y}  {(x,y). ?expr3 x y}
      = {(x,y). x<y  ?co'!s=x  ?co'!(Suc s)=y}
                           
                  {(x,y). x<y  ?co'!s=y  ?co'!(Suc s)=x}" . 

  have c2: "card ({(x,y). x<y  ?co'!s=x  ?co'!(Suc s)=y}
                           
                  {(x,y). x<y  ?co'!s=y  ?co'!(Suc s)=x}) = 1" (is "card (?A  ?B) = 1")
  proof (cases "?co'!s<?co'!(Suc s)")
    case True
    then have a: "?A = { (?co'!s, ?co'!(Suc s)) }"
          and b: "?B = {} " by auto
    have c: "?A  ?B = { (?co'!s, ?co'!(Suc s)) }" apply(simp only: a b) by simp 
    have "card (?A  ?B) = 1" unfolding c by auto
    then show ?thesis .
  next
    case False
    then have a: "?A = {}" by auto
    have b: "?B = { (?co'!(Suc s), ?co'!s) } "
    proof -
     from dco distinct_conv_nth[of "?co'"] 
     have "swaps ss init ! s  swaps ss init ! (Suc s)" 
      using isT2 isT3 by simp
     with False show ?thesis by auto
    qed

    have c: "?A  ?B = { (?co'!(Suc s), ?co'!s) }" apply(simp only: a b) by simp 
    have "card (?A  ?B) = 1" unfolding c by auto
    then show ?thesis .
  qed
    
        

  have yeah: "((x,y){(x,y). x  set init  yset init  x<y}. ?expr x y) = (1::nat)"
  proof -
    have "((x,y){(x,y). x  set init  yset init  x<y}. ?expr x y)
        = ((x,y){(x,y). x  set init  yset init  x<y}. ?expr2 x y)"
          using isT by auto
    also have " = (z{(x,y). x  set init  yset init  x<y}. ?expr2 (fst z) (snd z))"
        by(simp add: split_def)
    also have " = (z{(x,y). x  set init  yset init  x<y}. ?expr4 z)"
        by(simp add: split_def)
    also have " = (z{(x,y). x  set init  yset init  x<y}
                          {(x,y). ?expr3 x y} . 1)"
        apply(rule sum.inter_restrict[symmetric])
              apply(rule finite_subset[where B="set init × set init"])
                by(auto)
    also have " = card ({(x,y). x  set init  yset init  x<y}
                           {(x,y). ?expr3 x y})" by auto
    also have " = card ({(x,y). x<y  ?co'!s=x  ?co'!(Suc s)=y}
                           
                  {(x,y). x<y  ?co'!s=y  ?co'!(Suc s)=x})" by(simp only: c1)
    also have " = (1::nat)" using c2 by auto
    finally show ?thesis .
  qed

  have "length (s # ss) = 1 + length ss"
    by auto
  also have " = 1 + ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P ss x y init)"
    using iH by auto
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. ?expr x y)
            + ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P ss x y init)"
    by(simp only: yeah)
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. ?expr x y + ALG_P ss x y init)"
    (is "?A + ?B = ?C") 
    by (simp add: sum.distrib split_def)  
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (s#ss) x y init)"
    by auto
  finally show ?case . 
qed (simp)




(* thesame with paid exchanges *) 
lemma tp_sumofALGALGP:
assumes "distinct s" "(qs!i)set s"
  and "l< length (snd a). Suc ((snd a)!l) < length s"
shows "tp s (qs!i) a = (eset s. ALG e qs i (swaps (snd a) s,())) 
      + ((x,y){(x::('a::linorder),y). x  set s  yset s  x<y}. ALG_P (snd a) x y s)"
proof -
  (* paid exchanges *)
  have pe: "length (snd a)
        = ((x,y){(x,y). x  set s  yset s  x<y}. ALG_P (snd a) x y s)"   
    apply(rule ALG_P_erwischt_alle)  
        by(fact)+                                              

  (* access cost *)
  have ac: "index (swaps (snd a) s) (qs ! i) = (eset s. ALG e qs i (swaps (snd a) s,()))"
  proof -
    have "index (swaps (snd a) s) (qs ! i) 
        = (eset (swaps (snd a) s). if e < (qs ! i) in (swaps (snd a) s) then 1 else 0)" 
          apply(rule index_sum)
            using assms by(simp_all)
    also have " = (eset s. ALG e qs i (swaps (snd a) s,()))" by auto
    finally show ?thesis .
  qed

  show ?thesis
    unfolding tp_def apply (simp add: split_def)
    unfolding ac pe by (simp add: split_def)
qed


(* given a Strategy Strat to serve request sequence qs on initial list init how many
  swaps between elements x and y occur during the ith step *)
definition "ALG_P' Strat qs init i x y = ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)"

(* if n is in bound, Strat may be too long, that does not matter *)
lemma ALG_P'_rest: "n < length qs  n < length Strat  
  ALG_P' Strat (take n qs @ [qs ! n]) init n x y =
    ALG_P' (take n Strat @ [Strat ! n]) (take n qs @ [qs ! n]) init n x y"
proof -
  assume qs: "n < length qs"
  assume S: "n < length Strat"

  then have lS: "length (take n Strat) = n" by auto
  have "(take n Strat @ [Strat ! n]) ! n =
      (take n Strat @ (Strat ! n) # []) ! length (take n Strat)" using lS by auto
  also have " = Strat ! n" by(rule nth_append_length)
  finally have tt: "(take n Strat @ [Strat ! n]) ! n = Strat ! n" .

  obtain rest where rest: "Strat = (take n Strat @ [Strat ! n] @ rest)" 
        using S apply(auto) using id_take_nth_drop by blast

  have "steps' init (take n qs @ [qs ! n])
       (take n Strat @ [Strat ! n]) n
      = steps' init (take n qs)
       (take n Strat) n"
       apply(rule steps'_rests[symmetric])
        using S qs by auto
  also have " = 
      steps' init (take n qs @ [qs ! n])
       (take n Strat @ ([Strat ! n] @ rest)) n"
       apply(rule steps'_rests)
        using S qs by auto
  finally show ?thesis unfolding ALG_P'_def tt using rest by auto
qed

(* verallgemeinert ALG_P'_rest, sollte mergen! *)
lemma ALG_P'_rest2: "n < length qs  n < length Strat  
  ALG_P' Strat qs init n x y =
    ALG_P' (Strat@r1) (qs@r2) init n x y"
proof -
  assume qs: "n < length qs"
  assume S: "n < length Strat"

  have tt: "Strat ! n = (Strat @ r1) ! n"
    using S by (simp add: nth_append)

  have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ drop n qs) ((take n Strat) @ (drop n Strat)) n"
       apply(rule steps'_rests)
        using S qs by auto
  then have A: "steps' init (take n qs) (take n Strat) n = steps' init qs Strat n" by auto
  have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ ((drop n qs)@r2)) ((take n Strat) @((drop n Strat)@r1)) n"
       apply(rule steps'_rests)
        using S qs by auto
  then have B: "steps' init (take n qs) (take n Strat) n = steps' init (qs@r2) (Strat@r1) n"
    by (metis append_assoc List.append_take_drop_id)
  from A B have C: "steps' init qs Strat n = steps' init (qs@r2) (Strat@r1) n" by auto
  show ?thesis unfolding ALG_P'_def tt using C by auto

qed



(* total number of swaps of elements x and y during execution of Strategy Strat *)
definition ALG_Pxy  where
  "ALG_Pxy Strat qs init x y = (i<length qs. ALG_P' Strat qs init i x y)"

lemma wegdamit: "length A < length Strat  b  {x,y}  ALGxy_det Strat (A @ [b]) init x y
    = ALGxy_det Strat A init x y" 
proof -
  assume bn: "b  {x,y}"
  have "(A @ [b]) ! (length A) = b" by auto
  assume l: "length A < length Strat"

  term "%i. ALG'_det Strat (A @ [b]) init i y"

  have e: "i. i<length A  (A @ [b]) ! i = A ! i" by(auto simp: nth_append)
 have "(i {..< length (A @ [b])}.
        if (A @ [b]) ! i  {y, x}
        then ALG'_det Strat (A @ [b]) init i y +
             ALG'_det Strat (A @ [b]) init i x
        else 0) = (i {..< Suc(length (A))}.
        if (A @ [b]) ! i  {y, x}
        then ALG'_det Strat (A @ [b]) init i y +
             ALG'_det Strat (A @ [b]) init i x
        else 0)" by auto 
  also have " = (i {..< (length (A))}.
        if (A @ [b]) ! i  {y, x}
        then ALG'_det Strat (A @ [b]) init i y +
             ALG'_det Strat (A @ [b]) init i x
        else 0) + ( if (A @ [b]) ! (length A)  {y, x}
        then ALG'_det Strat (A @ [b]) init (length A) y +
             ALG'_det Strat (A @ [b]) init (length A) x
        else 0) " by simp (* abspalten des letzten glieds *)
        also have " = (i {..< (length (A))}.
        if (A @ [b]) ! i  {y, x}
        then ALG'_det Strat (A @ [b]) init i y +
             ALG'_det Strat (A @ [b]) init i x
        else 0)" using bn by auto
        also have " = (i {..< (length (A))}.
          if A ! i  {y, x}
          then ALG'_det Strat A init i y +
              ALG'_det Strat A init i x
              else 0)"
            apply(rule sum.cong)
              apply(simp)
              using l ALG'_det_append[where qs=A] e by(simp)
     finally show ?thesis unfolding ALGxy_det_def by simp
qed

lemma ALG_P_split: "length qs < length Strat  ALG_Pxy Strat (qs@[q]) init x y = ALG_Pxy Strat qs init x y
            +  ALG_P' Strat (qs@[q]) init (length qs) x y "
unfolding ALG_Pxy_def apply(auto)
  apply(rule sum.cong)
    apply(simp)
    using ALG_P'_rest2[symmetric, of _ qs Strat "[]" "[q]"] by(simp)
    

lemma swap0in2:  assumes "set l = {x,y}" "xy" "length l = 2" "dist_perm l l"
  shows
    "x < y in (swap 0) l = (~ x < y in l)"
proof (cases "x < y in l")
  case True
  then have a: "index l x < index l y" unfolding before_in_def by simp
  from assms(1) have drin: "xset l" "yset l" by auto
  from assms(1,3) have b: "index l y < 2" by simp
  from a b have k: "index l x = 0" "index l y = 1" by auto 

  have g: "x = l ! 0" "y = l ! 1"
    using k nth_index assms(1) by force+ 

      have "x < y in swap 0 l
      = (x < y in l  ¬ (x = l ! 0  y = l ! Suc 0)
              x = l ! Suc 0  y = l ! 0)"
            apply(rule before_in_swap)
              apply(fact assms(4))
              using assms(3) by simp
  also have " = (¬ (x = l ! 0  y = l ! Suc 0)
              x = l ! Suc 0  y = l ! 0)" using True by simp
  also have " = False" using g assms(2) by auto
  finally have "~ x < y in (swap 0) l" by simp
  then show ?thesis using True by auto
next
  case False
  from assms(1,2) have "index l y  index l x" by simp
  with False assms(1,2) have a: "index l y < index l x"
    by (metis before_in_def insert_iff linorder_neqE_nat)
  from assms(1) have drin: "xset l" "yset l" by auto
  from assms(1,3) have b: "index l x < 2" by simp
  from a b have k: "index l x = 1" "index l y = 0" by auto
  then have g: "x = l ! 1" "y = l ! 0" 
    using k nth_index assms(1) by force+ 
  have "x < y in swap 0 l
      = (x < y in l  ¬ (x = l ! 0  y = l ! Suc 0)
              x = l ! Suc 0  y = l ! 0)"
            apply(rule before_in_swap)
              apply(fact assms(4))
              using assms(3) by simp
  also have " = (x = l ! Suc 0  y = l ! 0)" using False by simp
  also have " = True" using g by auto
  finally have "x < y in (swap 0) l" by simp
  then show ?thesis using False by auto
qed 



lemma before_in_swap2:
 "dist_perm xs ys  Suc n < size xs  xy 
  x < y in (swap n xs) 
  (~ x < y in xs  (y = xs!n  x = xs!Suc n)
       x < y in xs  ~(y = xs!Suc n  x = xs!n))"
apply(simp add:before_in_def index_swap_distinct)
by (metis Suc_lessD Suc_lessI index_nth_id less_Suc_eq nth_mem yes)

lemma projected_paid_same_effect: 
  assumes
   d: "dist_perm s1 s1"  
  and ee: "xy"  
  and f: "set s2 = {x, y}"  
  and g: "length s2 = 2"  
  and h: "dist_perm s2 s2"  
  shows "x < y in s1 = x < y in s2 
  x < y in swaps acs s1 = x < y in (swap 0 ^^ ALG_P acs x y s1) s2"
proof (induct acs)
  case Nil
  then show ?case by auto
next
  case (Cons s ss)
  from d have dd: "dist_perm (swaps ss s1) (swaps ss s1)" by simp
  from f have ff: "set ((swap 0 ^^ ALG_P ss x y s1) s2) = {x, y}" by (metis foldr_replicate swaps_inv)
  from g have gg: "length ((swap 0 ^^ ALG_P ss x y s1) s2) = 2"  by (metis foldr_replicate swaps_inv)
  from h have hh: "dist_perm ((swap 0 ^^ ALG_P ss x y s1) s2) ((swap 0 ^^ ALG_P ss x y s1) s2)" by (metis foldr_replicate swaps_inv) 
  show ?case (is "?LHS = ?RHS")
  proof (cases "Suc s < length (swaps ss s1)  (((swaps ss s1)!s=x  (swaps ss s1)!(Suc s)=y)  ((swaps ss s1)!s=y  (swaps ss s1)!(Suc s)=x))")
    case True
    from True have 1:" Suc s < length (swaps ss s1)"
          and 2: "(swaps ss s1 ! s = x  swaps ss s1 ! Suc s = y
              swaps ss s1 ! s = y  swaps ss s1 ! Suc s = x)" by auto
    from True have "ALG_P (s # ss) x y s1 =  1 + ALG_P ss x y s1" by auto
    then have "?RHS = x < y in (swap 0) ((swap 0 ^^ ALG_P ss x y s1) s2)"
      by auto
    also have " = (~ x < y in ((swap 0 ^^ ALG_P ss x y s1) s2))" 
      apply(rule swap0in2)
        by(fact)+
    also have " = (~ x < y in swaps ss s1)" 
      using Cons by auto
    also have " = x < y in (swap s) (swaps ss s1)"
      using 1  2 before_in_swap
      by (metis Suc_lessD before_id dd lessI no_before_inI) (* bad *)
    also have " = ?LHS" by auto
    finally show ?thesis by simp
  next
    case False
    note F=this
    then have "ALG_P (s # ss) x y s1 =  ALG_P ss x y s1" by auto
    then have "?RHS = x < y in ((swap 0 ^^ ALG_P ss x y s1) s2)"
      by auto
    also have " = x < y in swaps ss s1" 
      using Cons by auto
    also have " = x < y in (swap s) (swaps ss s1)"
    proof (cases "Suc s < length (swaps ss s1)")
      case True
      with F have g: "swaps ss s1 ! s  x 
         swaps ss s1 ! Suc s  y" and
        h: "swaps ss s1 ! s  y 
         swaps ss s1 ! Suc s  x" by auto 
         show ?thesis 
          unfolding before_in_swap[OF dd True, of x y] apply(simp)
            using g h by auto
    next
      case False
      then show ?thesis unfolding swap_def by(simp)
    qed
    also have " = ?LHS" by auto
    finally show ?thesis by simp
  qed
qed 
  

lemma steps_steps':
  "length qs = length as  steps s qs as = steps' s qs as (length as)"
by (induct qs as arbitrary: s rule: list_induct2) (auto)


lemma T1_7': "Tp init qs Strat = Tp_opt init qs  length Strat = length qs
       nlength qs   
      x(y::('a::linorder)) 
      x set init  y  set init  distinct init 
      set qs  set init 
      (Strat2 sws. 
        ⌦‹Tp_opt (Lxy init {x,y}) (Lxy (take n qs) {x,y}) ≤ Tp (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2
          ∧›  length Strat2 = length (Lxy (take n qs) {x,y})
               (x < y in (steps' init (take n qs) (take n Strat) n))
              = (x < y in (swaps sws (steps' (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2 (length Strat2))))
           Tp (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2 + length sws =            
          ALGxy_det Strat (take n qs) init x y + ALG_Pxy Strat (take n qs) init x y)"
proof(induct n)
  case (Suc n)
  from Suc(3,4) have ns: "n < length qs" by simp
  then have n: "n  length qs" by simp
  from Suc(1)[OF Suc(2) Suc(3) n Suc(5) Suc(6) Suc(7) Suc(8) Suc(9) ] obtain Strat2 sws where 
  (*S2: "Tp_opt (Lxy init {x,y}) (Lxy (take n qs) {x, y})
     ≤ Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2"
     and *) len: "length Strat2 = length (Lxy (take n qs) {x, y})"
     and iff:
      "x < y in steps' init (take n qs) (take n Strat) n
         =
       x < y in swaps sws (steps' (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2))"   

     and T_Strat2: "Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 + length sws =
     ALGxy_det Strat (take n qs) init x y +
     ALG_Pxy Strat (take n qs) init x y "  by (auto) 
     
  from Suc(3-4) have nStrat: "n < length Strat" by auto 
  from take_Suc_conv_app_nth[OF this] have tak2: "take (Suc n) Strat = take n Strat @ [Strat ! n]" by auto


  from take_Suc_conv_app_nth[OF ns] have tak: "take (Suc n) qs = take n qs @ [qs ! n]" by auto

  have aS: "length (take n Strat) = n" using Suc(3,4) by auto
  have aQ: "length (take n qs) = n" using Suc(4) by auto
  from aS aQ have qQS: "length (take n qs) = length (take n Strat)" by auto

  have xyininit: "x set init" "y : set init" by fact+
  then have xysubs: "{x,y}  set init" by auto
  have dI:  "distinct init" by fact
  have "set qs  set init" by fact
  then have qsnset: "qs ! n  set init" using ns by auto

  from xyininit have ahjer: "set (Lxy init {x, y}) = {x,y}" 
    using xysubs by (simp add: Lxy_set_filter)
  with Suc(5) have ah: "card (set (Lxy init {x, y})) = 2" by simp
  have ahjer3: "distinct (Lxy init {x,y})"           
    apply(rule Lxy_distinct) by fact
  from ah have ahjer2: "length (Lxy init {x,y}) = 2"
    using distinct_card[OF ahjer3] by simp

  show ?case
  proof (cases "qs ! n  {x,y}")
    case False
    with tak have nixzutun: "Lxy (take (Suc n) qs) {x,y}  = Lxy (take n qs) {x,y}"
      unfolding Lxy_def by simp
    let ?m="ALG_P' (take n Strat @ [Strat ! n]) (take n qs @ [qs ! n]) init n x y"
    let ?L="replicate ?m 0 @ sws" 

    {
      fix xs::"('a::linorder) list"
      fix m::nat
      fix q::'a
      assume "q  {x,y}"
      then have 5: "y  q" by auto
      assume 1: "q  set xs"
      assume 2: "distinct xs"
      assume 3: "x  set xs"
      assume 4: "y  set xs"
      have "(x < y in xs) = (x < y in (mtf2 m q xs))"
        by (metis "1" "2" "3" "4" q  {x, y} insertCI not_before_in set_mtf2 swapped_by_mtf2)
    } note f=this

    (* taktik, erstmal das mtf weg bekommen,
       dann induct über snd (Strat!n) *)
    have "(x < y in steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n))
            = (x < y in mtf2 (fst (Strat ! n)) (qs ! n)
             (swaps (snd (Strat ! n)) (steps' init (take n qs) (take n Strat) n)))"       
      unfolding tak2 tak apply(simp only: steps'_append[OF qQS aQ] )
      by (simp add: step_def split_def) 
    also have " = (x < y in (swaps (snd (Strat ! n)) (steps' init (take n qs) (take n Strat) n)))"
      apply(rule f[symmetric])
         apply(fact)
        using qsnset steps'_set[OF qQS] aS apply(simp)
       using steps'_distinct[OF qQS] aS dI apply(simp) 
      using steps'_set[OF qQS] aS xyininit by simp_all
    also have " =  x < y in (swap 0 ^^ ALG_P (snd (Strat ! n)) x y (steps' init (take n qs) (take n Strat) n))
                                    (swaps sws (steps' (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2)))"
       apply(rule projected_paid_same_effect)
            apply(rule steps'_dist_perm)
              apply(fact qQS)
             apply(fact aS)
            using dI apply(simp)
           apply(fact Suc(5))
          apply(simp)
          apply(rule steps'_set[where s="Lxy init {x,y}", unfolded ahjer])
           using len apply(simp)
          apply(simp)
         apply(simp)
         apply(rule steps'_length[where s="Lxy init {x,y}", unfolded ahjer2])
          using len apply(simp)
         apply(simp)
        apply(simp)
        apply(rule steps'_distinct2[where s="Lxy init {x,y}"])
          using len apply(simp)
         apply(simp)
        apply(fact)
       using iff by auto
                             
    finally have umfa: "x < y in steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n) =
  x < y
  in (swap 0 ^^ ALG_P (snd (Strat ! n)) x y (steps' init (take n qs) (take n Strat) n))
      (swaps sws (steps' (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2)))" .

    from Suc(3,4) have lS: "length (take n Strat) = n" by auto
    have "(take n Strat @ [Strat ! n]) ! n =
              (take n Strat @ (Strat ! n) # []) ! length (take n Strat)" using lS by auto
    also have " = Strat ! n" by(rule nth_append_length)
    finally have tt: "(take n Strat @ [Strat ! n]) ! n = Strat ! n" .

    show ?thesis
      apply(rule exI[where x="Strat2"])
      apply(rule exI[where x="?L"])
      unfolding nixzutun
      apply(safe)
         apply(fact)
        proof goal_cases
          case 1
          show ?case 
          unfolding tak2 tak 
          apply(simp add: step_def split_def)
          unfolding ALG_P'_def
          unfolding tt
            using aS apply(simp only: steps'_rests[OF qQS, symmetric])
           using 1(1) umfa by auto 
        next
          case 2
          then show ?case  
          apply(simp add: step_def split_def)
          unfolding ALG_P'_def
          unfolding tt 
            using aS apply(simp only: steps'_rests[OF qQS, symmetric])
            using umfa[symmetric] by auto
        next
          case 3
          have ns2: "n < length (take n qs @ [qs ! n])"
              using ns by auto

          have er: "length (take n qs) < length Strat" 
            using Suc.prems(2) aQ ns by linarith

          have "Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
      + length (replicate (ALG_P' Strat (take n qs @ [qs ! n]) init n x y) 0 @ sws)
      = ( Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 + length sws)
          + ALG_P' Strat (take n qs @ [qs ! n])  init n x y" by simp

          also have " =  ALGxy_det Strat (take n qs) init x y +
                  ALG_Pxy Strat (take n qs) init x y +
                  ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
            unfolding T_Strat2 by simp
          also
          have " = ALGxy_det Strat (take (Suc n) qs) init x y
              + ALG_Pxy Strat (take (Suc n) qs) init x y"
            unfolding tak unfolding wegdamit[OF er False] apply(simp) 
            unfolding ALG_P_split[of "take n qs" Strat "qs ! n" init x y, unfolded aQ, OF nStrat]
            by(simp)
          finally show ?case unfolding tak using ALG_P'_rest[OF ns nStrat] by auto 
        qed
  next
    case True
    note qsinxy=this
    then have yeh: "Lxy (take (Suc n) qs) {x, y} = Lxy (take n qs) {x,y} @ [qs!n]"
      unfolding tak Lxy_def by auto

    from True have garar: "(take n qs @ [qs ! n]) ! n  {y, x}"
      using tak[symmetric] by(auto)
    have aer: "i<n.
        ((take n qs @ [qs ! n]) ! i  {y, x})
          = (take n qs ! i  {y, x})" using ns by (metis less_SucI nth_take tak)

    (* erst definiere ich die zwischenzeitlichen Configurationen
               ?xs  → ?xs'  → ?xs''
        und
        ?ys → ?ys' → ?ys'' → ?ys'''

        und einige Eigenschaften über sie
    *)

    (* what is the mtf action taken by Strat? *)
    let ?Strat_mft =  "fst (Strat ! n)"
    let ?Strat_sws =  "snd (Strat ! n)"
    (* what is the configuration before the step? *)  
    let ?xs = "steps' init (take n qs) (take n Strat) n"
    (* what is the configuration before the mtf *)
    let ?xs' = "(swaps (snd (Strat!n)) ?xs)"
    let ?xs'' = "steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n)"
    let ?xs''2 = "mtf2 ?Strat_mft (qs!n) ?xs'"
    (* position of requested element *)
    let ?no_swap_occurs = "(x < y in ?xs') = (x < y in ?xs''2)"

    let ?mtf="(if ?no_swap_occurs then 0 else 1::nat)"
    let ?m="ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
    let ?L="replicate ?m 0 @ sws"

    let ?newStrat="Strat2@[(?mtf,?L)]"

    have "?xs'' =  step ?xs (qs!n) (Strat!n)"
      unfolding tak tak2
      apply(rule steps'_append) by fact+
    also have " = mtf2 (fst (Strat!n)) (qs!n) (swaps (snd (Strat!n)) ?xs)" unfolding step_def
      by (auto simp: split_def)
    finally have A: "?xs'' = mtf2 (fst (Strat!n)) (qs!n) ?xs'" . 

    let ?ys = "(steps' (Lxy init {x, y})
                  (Lxy (take n qs) {x, y}) Strat2 (length Strat2))"
    let ?ys' = "( swaps sws (steps' (Lxy init {x, y})
                  (Lxy (take n qs) {x, y}) Strat2 (length Strat2)))"
    let ?ys'' = " (swap 0 ^^ ALG_P (snd (Strat!n)) x y ?xs) ?ys'"
    let ?ys''' = "(steps' (Lxy init {x, y}) (Lxy (take (Suc n) qs) {x, y}) ?newStrat (length ?newStrat))"

    have gr: "Lxy (take n qs @ [qs ! n]) {x, y} = 
        Lxy (take n qs) {x, y} @ [qs ! n]" unfolding Lxy_def using True by(simp)

    have "steps' init (take n qs @ [qs ! n]) Strat n
      = steps' init (take n qs @ [qs ! n]) (take n Strat @ drop n Strat) n" by simp
    also have " = steps' init (take n qs) (take n Strat) n"
          apply(subst steps'_rests[symmetric]) using aS qQS by(simp_all)
    finally have t: "steps' init (take n qs @ [qs ! n]) Strat n
        = steps' init (take n qs) (take n Strat) n" .
    have gge: "swaps (replicate ?m 0) ?ys'
        =  (swap 0 ^^ ALG_P (snd (Strat!n)) x y ?xs) ?ys'"
          unfolding ALG_P'_def t by simp

    have gg: "length ?newStrat = Suc (length Strat2)" by auto
    have "?ys''' =  step ?ys (qs!n) (?mtf,?L)"
          unfolding tak gr unfolding gg
          apply(rule steps'_append)
            using len by auto
    also have " = mtf2 ?mtf (qs!n) (swaps ?L ?ys)"
          unfolding step_def by (simp add: split_def)
    also have " = mtf2 ?mtf (qs!n) (swaps (replicate ?m 0) ?ys')"
      by (simp)
    also have " = mtf2 ?mtf (qs!n) ?ys''"
      using gge by (simp)
    finally have B: "?ys''' = mtf2 ?mtf (qs!n) ?ys''" .
 
    have 3: "set ?ys' = {x,y}"
      apply(simp add: swaps_inv) apply(subst steps'_set) using ahjer len by(simp_all)  
    have k: "?ys'' = swaps (replicate (ALG_P (snd (Strat!n)) x y ?xs) 0) ?ys'"
      by (auto)
    have 6: "set ?ys'' = {x,y}" unfolding k using 3 swaps_inv by metis
    have 7: "set ?ys''' = {x,y}" unfolding B using set_mtf2 6 by metis                              
    have 22: "x  set ?ys''" "y  set ?ys''" using 6 by auto
    have 23: "x  set ?ys'''" "y  set ?ys'''" using 7 by auto

    have 26: "(qs!n)  set ?ys''" using 6 True by auto

    have "distinct ?ys" apply(rule steps'_distinct2)
      using len ahjer3 by(simp)+
    then have 9: "distinct ?ys'" using swaps_inv by metis              
    then have 27: "distinct ?ys''" unfolding k  using swaps_inv by metis

    from 3 Suc(5) have "card (set ?ys') = 2" by auto
    then have 4: "length ?ys' = 2" using distinct_card[OF 9] by simp
    have "length ?ys'' = 2" unfolding k using 4 swaps_inv by metis
    have 5: "dist_perm ?ys' ?ys'" using 9 by auto

    have sxs: "set ?xs = set init" apply(rule steps'_set) using qQS n Suc(3) by(auto)
    have sxs': "set ?xs' = set ?xs" using swaps_inv by metis
    have sxs'': "set ?xs'' = set ?xs'" unfolding A using set_mtf2 by metis
    have 24: "x  set ?xs'" "yset ?xs'" "(qs!n)  set ?xs'" 
        using xysubs True sxs sxs' by auto
    have 28: "x  set ?xs''" "yset ?xs''" "(qs!n)  set ?xs''"  
        using xysubs True sxs sxs' sxs'' by auto

    have 0: "dist_perm init init" using dI by auto
    have 1: "dist_perm ?xs ?xs" apply(rule steps'_dist_perm)
      by fact+
    then have 25: "distinct ?xs'" using swaps_inv by metis


    (* aus der Induktionsvorraussetzung (iff) weiß ich bereits
        dass die Ordnung erhalten wird bis zum nten Schritt,
        mit Theorem "projected_paid_same_effect" kann ich auch die paid exchanges abarbeiten ...*)

    from projected_paid_same_effect[OF 1 Suc(5) 3 4 5, OF iff, where acs="snd (Strat ! n)"]
    have aaa: "x < y in ?xs'  = x < y in ?ys''" .

    (* ... was nun noch fehlt ist, dass die moveToFront anweisungen von Strat
        und Strat2 sich in gleicher Art auf die Ordnung von x und y auswirken
    *)

    have t: "?mtf = (if (x<y in ?xs') = (x<y in ?xs'') then 0 else 1)"
      by (simp add: A)

    have central: "x < y in ?xs'' = x < y  in ?ys'''"
    proof (cases "(x<y in ?xs') = (x<y in ?xs'')")
      case True
      then have "?mtf = 0" using t by auto
      with B have "?ys''' = ?ys''" by auto
      with aaa True show ?thesis by auto
    next
      case False
      then have k: "?mtf = 1" using t by auto
      from False have i: "(x<y in ?xs') = (~x<y in ?xs'')" by auto

      have gn: "a b. a{x,y}  b{x,y}  set ?ys'' = {x,y} 
                  ab  distinct ?ys'' 
                  a<b in ?ys''  ~a<b in mtf2 1 b ?ys''"
      proof goal_cases
        case (1 a b)
        from 1 have f: "set ?ys'' = {a,b}" by auto
        with 1 have i: "card (set ?ys'') = 2" by auto
        from 1(5) have "dist_perm ?ys'' ?ys''" by auto 
        from i distinct_card 1(5) have g: "length ?ys'' = 2" by metis
        with 1(6) have d: "index ?ys'' b = 1"
          using before_in_index2 f 1(4) by fastforce
        from 1(2,3) have e: "b  set ?ys''" by auto

        from d e have p: "mtf2 1 b ?ys'' = swap 0 ?ys''"
          unfolding mtf2_def by auto
        have q: "a < b in swap 0 ?ys'' = (¬ a < b in ?ys'')"
          apply(rule swap0in2) by(fact)+
        from 1(6) p q show ?case by metis
      qed

      show ?thesis
      proof (cases "x<y in ?xs'")
        case True
        with aaa have st: "x < y in ?ys''" by auto
        from True False have "~ x<y in ?xs''" by auto
        with Suc(5) 28 not_before_in A have "y < x in ?xs''" by metis
        with A have "y < x in mtf2 (fst (Strat!n)) (qs!n) ?xs'" by auto
        (*from True swapped_by_mtf2*)
        have itisy: "y = (qs!n)"
          apply(rule swapped_by_mtf2[where xs= ?xs'])
               apply(fact)
              apply(fact)
             apply(fact 24)
            apply(fact 24)
           by(fact)+
        have "~x<y in mtf2 1 y ?ys''" 
          apply(rule gn)
               apply(simp)
              apply(simp)
             apply(simp add: 6)
            by(fact)+
        then have ts: "~x<y in ?ys'''" using B itisy k by auto
        have ii: "(x<y in ?ys'') = (~x<y in ?ys''')" using st ts by auto
        from i ii aaa show ?thesis by metis
      next
        case False
        with aaa have st: "~ x < y in ?ys''" by auto
        with Suc(5) 22 not_before_in have st: "y < x in ?ys''" by metis
        from i False have kl: "x<y in ?xs''" by auto
        with A have "x < y in mtf2 (fst (Strat!n)) (qs!n) ?xs'" by auto
        from False Suc(5) 24 not_before_in have "y < x in ?xs'" by metis
        have itisx: "x = (qs!n)"
          apply(rule swapped_by_mtf2[where xs= ?xs'])
               apply(fact)
              apply(fact)
             apply(fact 24(2))
            apply(fact 24)
           by(fact)+
        have "~y<x in mtf2 1 x ?ys''"
          apply(rule gn)
               apply(simp)
              apply(simp)
             apply(simp add: 6)
            apply(metis Suc(5))
           by(fact)+
        then have "~y<x in ?ys'''" using itisx k B by auto
        with Suc(5) not_before_in 23 have "x<y in ?ys'''" by metis
        with st have "(x<y in ?ys'') = (~x<y in ?ys''')" using  B k by auto
        with i aaa show ?thesis by metis
      qed
    qed

    show ?thesis
      apply(rule exI[where x="?newStrat"])
      apply(rule exI[where x="[]"])
      proof (standard, goal_cases)
        case 1
        show ?case unfolding yeh using len by(simp)
      next
        case 2
        show ?case
        proof (standard, goal_cases)
          case 1
          (* hier beweise ich also, dass die ordnung von x und y in der projezierten
             Ausführung (von Strat2) der Ordnung von x und y in der Ausführung
             von Strat entspricht *)
          from central show ?case by auto
        next
          case 2 
          (* nun muss noch bewiesen werden, dass die Kosten sich richtig aufspalten:
             Kosten für Strat2 + |sws|
             = blocking kosten von x,y + paid exchange kosten von x,y
          *)
          have j: "ALGxy_det Strat (take (Suc n) qs) init x y =
            ALGxy_det Strat (take n qs) init x y 
                  + (ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)" 
          proof -
            have "ALGxy_det Strat (take (Suc n) qs) init x y =
              (i{..<length (take n qs @ [qs ! n])}.
              if (take n qs @ [qs ! n]) ! i  {y, x}
              then ALG'_det Strat (take n qs @ [qs ! n]) init i y
                + ALG'_det Strat (take n qs @ [qs ! n]) init i x
              else 0)" unfolding ALGxy_det_def tak by auto
            also have "
              =  (i{..<Suc n}.
              if (take n qs @ [qs ! n]) ! i  {y, x}
              then ALG'_det Strat (take n qs @ [qs ! n]) init i y
                + ALG'_det Strat (take n qs @ [qs ! n]) init i x
              else 0)" using ns by simp
            also have " = (i{..<n}.
               if (take n qs @ [qs ! n]) ! i  {y, x}
               then ALG'_det Strat (take n qs @ [qs ! n]) init i y
                + ALG'_det Strat (take n qs @ [qs ! n]) init i x
               else 0)
               + (if (take n qs @ [qs ! n]) ! n  {y, x}
                  then ALG'_det Strat (take n qs @ [qs ! n]) init n y
                    + ALG'_det Strat (take n qs @ [qs ! n]) init n x
                  else 0)" by simp
            also have " = (i{..< n}.
              if take n qs ! i  {y, x}
              then ALG'_det Strat (take n qs @ [qs ! n]) init i y
                + ALG'_det Strat (take n qs @ [qs ! n]) init i x
              else 0)
                + ALG'_det Strat (take n qs @ [qs ! n]) init n y
                + ALG'_det Strat (take n qs @ [qs ! n]) init n x "
              using aer using garar by simp
            also have " = (i{..< n}.
              if take n qs ! i  {y, x}
              then ALG'_det Strat (take n qs @ [qs ! n]) init i y
                + ALG'_det Strat (take n qs @ [qs ! n]) init i x
              else 0)
                + ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
            proof -
              have "ALG'_det Strat qs init n y
                = ALG'_det Strat ((take n qs @ [qs ! n]) @ drop (Suc n) qs) init n y"
                unfolding tak[symmetric] by auto                   
              also have " = ALG'_det Strat (take n qs @ [qs ! n]) init n y "
                apply(rule ALG'_det_append) using nStrat ns by(auto)
              finally have 1: "ALG'_det Strat qs init n y = ALG'_det Strat (take n qs @ [qs ! n]) init n y" .
              have "ALG'_det Strat qs init n x
                  = ALG'_det Strat ((take n qs @ [qs ! n]) @ drop (Suc n) qs) init n x"
                unfolding tak[symmetric] by auto                   
              also have " = ALG'_det Strat (take n qs @ [qs ! n]) init n x "
                apply(rule ALG'_det_append) using nStrat ns by(auto)
              finally have 2: "ALG'_det Strat qs init n x = ALG'_det Strat (take n qs @ [qs ! n]) init n x" .
              from 1 2 show ?thesis by auto
            qed
            also have " = (i{..< n}.
              if take n qs ! i  {y, x}
              then ALG'_det Strat (take n qs) init i y
                  + ALG'_det Strat (take n qs) init i x
              else 0)
              + ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
              apply(simp)
              apply(rule sum.cong)
               apply(simp)
              apply(simp)
              using ALG'_det_append[where qs="take n qs"] Suc.prems(2) ns by auto
            also have " = (i{..< length(take n qs)}.
              if take n qs ! i  {y, x}
              then ALG'_det Strat (take n qs) init i y
                   + ALG'_det Strat (take n qs) init i x
              else 0)
              + ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
              using aQ by auto
            also have " = ALGxy_det Strat (take n qs) init x y 
                  + (ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)"
              unfolding ALGxy_det_def by(simp)
            finally show ?thesis .
          qed

           (* 
              aaa:      x < y in ?xs'  = x < y in ?ys''
              central:  x < y in ?xs'' = x < y  in ?ys''' 
           *) 

          have list: "?ys' = swaps sws (steps (Lxy init {x, y})  (Lxy (take n qs) {x, y}) Strat2)"
            unfolding steps_steps'[OF len[symmetric], of "(Lxy init {x, y})"] by simp

          have j2: "steps' init (take n qs @ [qs ! n]) Strat n
                  = steps' init (take n qs) (take n Strat) n"
          proof -
            have "steps' init (take n qs @ [qs ! n]) Strat n
                = steps' init (take n qs @ [qs ! n]) (take n Strat @ drop n Strat) n"
            by auto
            also have " = steps' init (take n qs) (take n Strat) n"
              apply(rule steps'_rests[symmetric]) apply fact using aS by simp
            finally show ?thesis .
          qed

          have arghschonwieder: "steps' init (take n qs) (take n Strat) n
                  = steps' init qs Strat n"
          proof -
            have "steps' init qs Strat n
                = steps' init (take n qs @ drop n qs) (take n Strat @ drop n Strat) n"
              by auto
            also have " = steps' init (take n qs) (take n Strat) n"
               apply(rule steps'_rests[symmetric]) apply fact using aS by simp
            finally show ?thesis by simp
          qed
 
          have indexe: "((swap 0 ^^ ?m) (swaps sws 
                      (steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) 
              = ?ys''" unfolding ALG_P'_def unfolding list using j2 by auto

          have blocky: "ALG'_det Strat qs init n y
                = (if y < qs ! n in ?xs' then 1 else 0)"
            unfolding ALG'_det_def ALG.simps by(auto simp: arghschonwieder split_def)
          have blockx: "ALG'_det Strat qs init n x
                = (if x < qs ! n in ?xs' then 1 else 0)"
            unfolding ALG'_det_def ALG.simps by(auto simp: arghschonwieder split_def)

          have index_is_blocking_cost: "index  ((swap 0 ^^ ?m) (swaps sws
                        (steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n)
                      = ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
          proof (cases "x= qs!n")
            case True
            then have "ALG'_det Strat qs init n x = 0"
              unfolding blockx apply(simp) using before_in_irefl by metis
            then have "ALG'_det Strat qs init n y + ALG'_det Strat qs init n x
                  = (if y < x in ?xs' then 1 else 0)" unfolding blocky using True by simp
            also have " = (if ~y < x in ?xs' then 0 else 1)" by auto
            also have " = (if x < y in ?xs' then 0 else 1)"
              apply(simp) by (meson 24 Suc.prems(4) not_before_in)
            also have " = (if x < y in ?ys'' then 0 else 1)" using aaa by simp
            also have " = index ?ys'' x"
              apply(rule before_in_index1) by(fact)+
            finally show ?thesis unfolding indexe using True by auto 
          next
            case False
            then have q: "y = qs!n" using qsinxy by auto
            then have "ALG'_det Strat qs init n y = 0"
              unfolding blocky apply(simp) using before_in_irefl by metis
            then have "ALG'_det Strat qs init n y + ALG'_det Strat qs init n x
                  = (if x < y in ?xs' then 1 else 0)" unfolding blockx using q by simp 
            also have " = (if x < y in ?ys'' then 1 else 0)" using aaa by simp
            also have " = index ?ys'' y"
              apply(rule before_in_index2) by(fact)+
            finally show ?thesis unfolding indexe using q by auto
          qed

          have jj: "ALG_Pxy Strat (take (Suc n) qs) init x y =
                ALG_Pxy Strat (take n qs) init x y
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
          proof -
            have "ALG_Pxy Strat (take (Suc n) qs) init x y
                  = (i<length (take (Suc n) qs). ALG_P' Strat (take (Suc n) qs) init i x y)" 
              unfolding ALG_Pxy_def by simp
            also have " = (i< Suc n. ALG_P' Strat (take (Suc n) qs) init i x y)"
              unfolding tak using ns by simp
            also have " = (i<n. ALG_P' Strat (take (Suc n) qs) init i x y)
                  + ALG_P' Strat (take (Suc n) qs) init n x y"
              by simp
            also have " = (i<length (take n qs). ALG_P' Strat (take n qs @ [qs ! n]) init i x y)
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
              unfolding tak using ns by auto
            also have " = (i<length (take n qs). ALG_P' Strat (take n qs) init i x y) 
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y" (is "?A + ?B = ?A' + ?B")
            proof -
              have "?A = ?A'"
                apply(rule sum.cong)
                  apply(simp)
                 proof goal_cases
                   case 1
                   show ?case
                     apply(rule ALG_P'_rest2[symmetric, where ?r1.0="[]", simplified])
                       using 1 apply(simp)
                      using 1 nStrat by(simp)
                 qed
                 then show ?thesis by auto
            qed                        
            also have " = ALG_Pxy Strat (take n qs) init x y
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y" 
                    unfolding ALG_Pxy_def by auto
            finally show ?thesis .
          qed

          have tw: "length (Lxy (take n qs) {x, y}) = length Strat2" 
            using len by auto
          have "Tp (Lxy init {x,y}) (Lxy (take (Suc n) qs) {x, y}) ?newStrat + length []
                 = Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
                  + tp (steps (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2) (qs ! n) (?mtf,?L)" 
            unfolding yeh
            by(simp add: T_append[OF tw, of "(Lxy init) {x,y}"]) 
          also have " = 
                 Tp (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
                  + length sws
                  + index ((swap 0 ^^ ?m) (swaps sws
                        (steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n)
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
            by(simp add: tp_def)
          (* now use iH *)
          also have " = (ALGxy_det Strat (take n qs) init x y 
                  + index ((swap 0 ^^ ?m) (swaps sws
                        (steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n))
                  + (ALG_Pxy Strat (take n qs) init x y
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y)"
            by (simp only: T_Strat2)
          (* the current cost are equal to the blocking costs: *)   
          also from index_is_blocking_cost have " = (ALGxy_det Strat (take n qs) init x y 
                  + ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)
                  + (ALG_Pxy Strat (take n qs) init x y
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y)" by auto
          also have " = ALGxy_det Strat (take (Suc n) qs) init x y 
                  + (ALG_Pxy Strat (take n qs) init x y
                  + ALG_P' Strat (take n qs @ [qs ! n]) init n x y)" using j by auto
          also have " = ALGxy_det Strat (take (Suc n) qs) init x y 
                  + ALG_Pxy Strat (take (Suc n) qs) init x y" using jj by auto
          finally show ?case .
        qed
      qed
    qed
next 
  case 0
  then show ?case
    apply (simp add: Lxy_def ALGxy_det_def ALG_Pxy_def T_opt_def)
    proof goal_cases
      case 1
        show ?case apply(rule Lxy_mono[unfolded Lxy_def, simplified])
          using 1 by auto
    qed
qed


lemma T1_7:
assumes "Tp init qs Strat = Tp_opt init qs" "length Strat = length qs"
  "x  (y::('a::linorder))" "x set init" "y  set init" "distinct init"
  "set qs  set init"
shows "Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})
   ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y"
proof -
  have A:"length qs  length qs" by auto
  have B:"  x  y " using assms by auto

  from T1_7'[OF assms(1,2), of "length qs" x y, OF A B assms(4-7)]
  obtain Strat2 sws where 
      len: "length Strat2 = length (Lxy qs {x, y})"
     and "x < y in steps' init qs (take (length qs) Strat)
         (length qs) = x < y in swaps sws (steps' (Lxy init {x,y})
           (Lxy qs {x, y}) Strat2 (length Strat2))"
     and Tp: "Tp (Lxy init {x,y}) (Lxy qs {x, y}) Strat2 + length sws
        =  ALGxy_det Strat qs init x y 
         + ALG_Pxy Strat qs init x y" by auto

  have "Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})  Tp (Lxy init {x,y}) (Lxy qs {x, y}) Strat2"
    unfolding T_opt_def
    apply(rule cInf_lower)
      using len by auto
  also have "  ALGxy_det Strat qs init x y 
         + ALG_Pxy Strat qs init x y" using Tp by auto
  finally show ?thesis .
qed

lemma T_snoc: "length rs = length as
         T init (rs@[r]) (as@[a])
        = T init rs as + tp (steps' init rs as (length rs)) r a"
apply(induct rs as arbitrary: init rule: list_induct2) by simp_all

lemma steps'_snoc: "length rs = length as  n = (length as)
        steps' init (rs@[r]) (as@[a]) (Suc n) = step (steps' init rs as n) r a"
apply(induct rs as arbitrary: init n r a rule: list_induct2)
  by (simp_all) 

lemma steps'_take:
  assumes "n<length qs" "length qs = length Strat" 
  shows "steps' init (take n qs) (take n Strat) n
      = steps' init qs Strat n"                       
proof -
  have "steps' init qs Strat n =
    steps' init (take n qs @ drop n qs) (take n Strat @ drop n Strat) n"  by simp
  also have " = steps' init (take n qs) (take n Strat) n"
      apply(subst steps'_rests[symmetric]) using assms  by auto
  finally show ?thesis by simp
qed

lemma Tp_darstellung: "length qs = length Strat
         Tp init qs Strat =
        (i{..<length qs}. tp (steps' init qs Strat i) (qs!i) (Strat!i))"   
proof -
  assume a[simp]: "length qs = length Strat"
  {fix n
      have "nlength qs
         Tp init (take n qs) (take n Strat) =
        (i{..<n}. tp (steps' init qs Strat i) (qs!i) (Strat!i))" 
      apply(induct n) 
        apply(simp)
       apply(simp add: take_Suc_conv_app_nth)
       apply(subst T_snoc)
         apply(simp)
        by(simp add: min_def steps'_take) 
  }
  from a this[of "length qs"] show ?thesis by auto
qed

         
(* Gleichung 1.8 in Borodin *)
lemma umformung_OPT':
  assumes inlist: "set qs  set init"
  assumes dist: "distinct init"
  assumes qsStrat: "length qs = length Strat"
  assumes noStupid: "x l. x<length Strat  l< length (snd (Strat ! x))  Suc ((snd (Strat ! x))!l)  < length init"
  shows "Tp init qs Strat = 
    ((x,y){(x,y::('a::linorder)). x  set init  yset init  x<y}.
          ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
proof -
 (* have config_dist: "∀n. ∀xa ∈ set_pmf (configp (I, S) qs init n). distinct (snd xa)"
      using dist config_rand_distinct by metis
*) 

  (* ersten Teil umformen: *)
  have "(i{..<length qs}.
    ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )
                = (i{..<length qs}. 
               (z{(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) (fst z) (snd z) (steps' init qs Strat i)) )"
          by(auto simp: split_def)
  also have "
       = (z{(x,y). x  set init  yset init  x<y}.
                (i{..<length qs}. ALG_P (snd (Strat!i)) (fst z) (snd z) (steps' init qs Strat i)) )" 
          by(rule sum.swap)
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}.
                (i{..<length qs}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
          by(auto simp: split_def)
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}.
                ALG_Pxy Strat qs init x y)"
          unfolding ALG_P'_def ALG_Pxy_def by auto
  finally have paid_part: "(i{..<length qs}.
    ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )
      = ((x,y){(x,y). x  set init  yset init  x<y}.
                ALG_Pxy Strat qs init x y)" .

  (* zweiten Teil umformen: *)
  
  let ?config = "(%i. swaps (snd (Strat!i)) (steps' init qs Strat i))"

  have "(i{..<length qs}. 
                (eset init. ALG e qs i (?config i, ())))
        = (eset init. 
            (i{..<length qs}. ALG e qs i (?config i, ())))" 
            by(rule sum.swap)
  also have " = (eset init.
          (yset init.
            (i{i. i<length qs  qs!i=y}. ALG e qs i (?config i,()))))"
            proof (rule sum.cong, goal_cases)
              case (2 x)
              have "(i<length qs. ALG x qs i (?config i, ()))
                = sum (%i. ALG x qs i (?config i, ())) {i. i<length qs}" 
                by (simp add: lessThan_def) 
              also have " = sum (%i. ALG x qs i (?config i, ())) 
                        (y{y. y  set init}. {i. i < length qs  qs ! i = y})"
                         apply(rule sum.cong)
                         proof goal_cases
                          case 1                          
                          show ?case apply(auto) using inlist by auto
                         qed simp
              also have " = sum (%t. sum (%i. ALG x qs i (?config i, ())) {i. i<length qs  qs ! i = t}) {y. y set init}"
                apply(rule sum.UNION_disjoint)
                  apply(simp_all) by force
              also have " = (yset init. i | i < length qs  qs ! i = y.
                       ALG x qs i (?config i, ()))" by auto                  
             finally show ?case .
            qed (simp)
   also have " = ((x,y) (set init × set init).
            (i{i. i<length qs  qs!i=y}. ALG x qs i (?config i, ())))"
       by (rule sum.cartesian_product)
   also have " = ((x,y) {(x,y). xset init  y set init}.
            (i{i. i<length qs  qs!i=y}. ALG x qs i (?config i, ())))"
            by simp
   also have E4: " = ((x,y){(x,y). xset init  y set init  xy}.
            (i{i. i<length qs  qs!i=y}. ALG x qs i (?config i, ())))" (is "((x,y) ?L. ?f x y) = ((x,y) ?R. ?f x y)")
           proof goal_cases
        case 1
        let ?M = "{(x,y). xset init  y set init  x=y}"
        have A: "?L = ?R  ?M" by auto
        have B: "{} = ?R  ?M" by auto
        have "((x,y) ?L. ?f x y) = ((x,y) ?R  ?M. ?f x y)"
          by(simp only: A)
        also have " = ((x,y) ?R. ?f x y) + ((x,y) ?M. ?f x y)"
            apply(rule sum.union_disjoint)
              apply(rule finite_subset[where B="set init × set init"])
                apply(auto)
              apply(rule finite_subset[where B="set init × set init"])
                by(auto)
        also have "((x,y) ?M. ?f x y) = 0"
          apply(rule sum.neutral)
            by (auto simp add: split_def before_in_def) 
        finally show ?case by simp
      qed

   also have " = ((x,y){(x,y). x  set init  yset init  x<y}.
            (i{i. i<length qs  qs!i=y}. ALG x qs i (?config i, ()))
           + (i{i. i<length qs  qs!i=x}. ALG y qs i (?config i, ())) )"
            (is "((x,y) ?L. ?f x y) = ((x,y) ?R. ?f x y +  ?f y x)")
              proof -
                let ?R' = "{(x,y). x  set init  yset init  y<x}"
                have A: "?L = ?R  ?R'" by auto
                have "{} = ?R  ?R'" by auto
                have C: "?R' = (%(x,y). (y, x)) ` ?R" by auto

                have D: "((x,y) ?R'. ?f x y) = ((x,y) ?R. ?f y x)"
                proof -
                  have "((x,y) ?R'. ?f x y) = ((x,y) (%(x,y). (y, x)) ` ?R. ?f x y)"
                      by(simp only: C)
                  also have "(z (%(x,y). (y, x)) ` ?R. (%(x,y). ?f x y) z) = (z?R. ((%(x,y). ?f x y)  (%(x,y). (y, x))) z)"
                    apply(rule sum.reindex)
                      by(fact swap_inj_on)
                  also have " = (z?R. (%(x,y). ?f y x) z)"
                    apply(rule sum.cong)
                      by(auto)
                  finally show ?thesis .                  
              qed

                have "((x,y) ?L. ?f x y) = ((x,y) ?R  ?R'. ?f x y)"
                  by(simp only: A) 
                also have " = ((x,y) ?R. ?f x y) + ((x,y) ?R'. ?f x y)"
                  apply(rule sum.union_disjoint) 
                    apply(rule finite_subset[where B="set init × set init"])
                      apply(auto)
                    apply(rule finite_subset[where B="set init × set init"])
                      by(auto)
                also have " = ((x,y) ?R. ?f x y) + ((x,y) ?R. ?f y x)"
                    by(simp only: D)                  
                also have " = ((x,y) ?R. ?f x y + ?f y x)"
                  by(simp add: split_def sum.distrib[symmetric])
              finally show ?thesis .
            qed
                
   also have E5: " = ((x,y){(x,y). x  set init  yset init  x<y}.
            (i{i. i<length qs  (qs!i=y  qs!i=x)}. ALG y qs i (?config i, ()) + ALG x qs i (?config i, ())))"
    apply(rule sum.cong)
      apply(simp)
      proof goal_cases
        case (1 x)
        then obtain a b where x: "x=(a,b)" and a: "a  set init" "b  set init" "a < b" by auto
        then have "ab" by simp
        then have disj: "{i. i < length qs  qs ! i = b}  {i. i < length qs  qs ! i = a} = {}" by auto
        have unio: "{i. i < length qs  (qs ! i = b  qs ! i = a)}
            = {i. i < length qs  qs ! i = b}  {i. i < length qs  qs ! i = a}" by auto 
        let ?f="%i. ALG b qs i (?config i, ()) +
               ALG a qs i (?config i, ())"
        let ?B="{i. i < length qs  qs ! i = b}"
        let ?A="{i. i < length qs  qs ! i = a}"
        have "(i?B  ?A. ?f i)
               = (i?B. ?f i) + (i?A. ?f i) - (i?B  ?A. ?f i) "
          apply(rule sum_Un_nat) by auto  
        also have " = (i?B. ALG b qs i (?config i, ()) + ALG a qs i (?config i, ()))
                    + (i?A. ALG b qs i (?config i, ()) + ALG a qs i (?config i, ()))"
          using disj by auto
        also have " = (i?B. ALG a qs i (?config i, ()))
                  + (i?A. ALG b qs i (?config i, ()))"
          by (auto simp: split_def before_in_def)
        finally 
            show ?case unfolding x apply(simp add: split_def)
          unfolding unio by simp
     qed    
     also have E6: " = ((x,y){(x,y). x  set init  yset init  x<y}.
                  ALGxy_det Strat qs init x y)"
           apply(rule sum.cong)
           unfolding ALGxy_det_alternativ unfolding ALG'_det_def by auto
     finally have blockingpart: "(i<length qs. 
                         eset init.
                              ALG e qs i (?config i, ()))
                 = ((x,y){(x,y). x  set init  yset init  x<y}. 
                         ALGxy_det Strat qs init x y) " .
  from Tp_darstellung[OF qsStrat] have E0: "Tp init qs Strat =
        (i{..<length qs}. tp (steps' init qs Strat i) (qs!i) (Strat!i))"
          by auto
  also have " = (i{..<length qs}. 
                (eset (steps' init qs Strat i). ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),()))
+ ((x,y){(x,(y::('a::linorder))). x  set (steps' init qs Strat i)  yset (steps' init qs Strat i)  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
    apply(rule sum.cong)
      apply(simp)
     apply (rule tp_sumofALGALGP) 
         apply(rule steps'_distinct2)
           using dist qsStrat apply(simp_all)
        apply(subst steps'_set)
          using dist qsStrat inlist apply(simp_all)
       apply fastforce
      apply(subst steps'_length)
        apply(simp_all)
          using noStupid by auto 
  also have " = (i{..<length qs}. 
                (eset init. ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),()))
+ ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
                apply(rule sum.cong)
                  apply(simp) 
                  proof goal_cases
                    case (1 x)
                    then have "set (steps' init qs Strat x) = set init"
                      apply(subst steps'_set)
                      using dist qsStrat 1 by(simp_all)
                    then show ?case by simp
                  qed 
  also have " = (i{..<length qs}. 
                (eset init. ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i), ())))
               + (i{..<length qs}. 
               ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
    by (simp add: sum.distrib split_def) 
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. 
                         ALGxy_det Strat qs init x y)
               + (i{..<length qs}. 
               ((x,y){(x,y). x  set init  yset init  x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
                by(simp only: blockingpart)
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. 
                         ALGxy_det Strat qs init x y)
               + ((x,y){(x,y). x  set init  yset init  x<y}.
                ALG_Pxy Strat qs init x y)"
                by(simp only: paid_part)
  also have " = ((x,y){(x,y). x  set init  yset init  x<y}. 
                         ALGxy_det Strat qs init x y
               +   ALG_Pxy Strat qs init x y)"
    by (simp add: sum.distrib split_def) 
  finally show ?thesis by auto
qed




lemma nn_contains_Inf:
  fixes S :: "nat set"
  assumes nn: "S  {}"
  shows "Inf S  S"
using assms Inf_nat_def LeastI by force


lemma steps_length: "length qs = length as  length (steps s qs as) = length s"
apply(induct qs as arbitrary: s rule: list_induct2)
   by simp_all

(* shows that OPT does not use paid exchanges that do not have an effect *)
lemma OPT_noStupid:
  fixes Strat
  assumes [simp]: "length Strat = length qs"
  assumes opt: "Tp init qs Strat = Tp_opt init qs"
  assumes init_nempty: "init[]"
  shows "x l. x < length Strat 
        l < length (snd (Strat ! x)) 
       Suc ((snd (Strat ! x))!l) < length init"
proof (rule ccontr, goal_cases)
  case (1 x l)

  (* construct a Stratgy that leaves out that paid exchange *)
  let ?sws' = "take l (snd (Strat!x)) @ drop (Suc l) (snd (Strat!x))"
  let ?Strat' = "take x Strat @ (fst (Strat!x),?sws') # drop (Suc x) Strat"

  from 1(1) have valid: "length ?Strat' = length qs" by simp
  from valid have isin: "Tp init qs ?Strat'  {Tp init qs as |as. length as = length qs}" by blast

  from 1(1,2) have lsws': "length (snd (Strat!x)) = length ?sws' + 1"
    by (simp)

  have a: "(take x ?Strat') = (take x Strat)"
    using 1(1) by(auto simp add: min_def take_Suc_conv_app_nth)
  have b: "(drop (Suc x) Strat) = (drop (Suc x) ?Strat')"
    using 1(1) by(auto simp add: min_def take_Suc_conv_app_nth)

  have aa: "(take l (snd (Strat!x))) = (take l (snd (?Strat'!x)))"
    using 1(1,2) by(auto simp add: min_def take_Suc_conv_app_nth nth_append)
  have bb: "(drop (Suc l) (snd (Strat!x))) = (drop l (snd (?Strat'!x)))"
    using 1(1,2) by(auto simp add: min_def take_Suc_conv_app_nth nth_append )
 
  have "(swaps (snd (Strat ! x)) (steps init (take x qs) (take x Strat)))
      = (swaps (take l (snd (Strat ! x)) @ (snd (Strat ! x))!l # drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
      unfolding id_take_nth_drop[OF 1(2), symmetric] by simp
  also have "...
      = (swaps (take l (snd (Strat ! x)) @ drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
        using 1(3) by(simp add: swap_def steps_length)
  finally have noeffect: "(swaps (snd (Strat ! x)) (steps init (take x qs) (take x Strat)))
      = (swaps (take l (snd (Strat ! x)) @ drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
      .
      

  have c: "tp (steps init (take x qs) (take x Strat)) (qs ! x) (Strat ! x) = 
        tp (steps init (take x qs) (take x ?Strat')) (qs ! x) (?Strat' ! x) + 1"
    unfolding a tp_def using 1(1,2)
    apply(simp add: min_def split_def nth_append) unfolding noeffect
    by(simp) 

  have "Tp init (take (Suc x) qs) (take (Suc x) Strat)
        = Tp init (take x qs) (take x ?Strat') + 
              tp (steps init (take x qs) (take x Strat)) (qs ! x) (Strat ! x)"
        using 1(1) a by(simp add: take_Suc_conv_app_nth T_append)
  also have " = Tp init (take x qs) (take x ?Strat')  + 
              tp (steps init (take x qs) (take x ?Strat')) (qs ! x) (?Strat' ! x) + 1"
              unfolding c by(simp)
  also have " = Tp init (take (Suc x) qs) (take (Suc x) ?Strat')  + 1"
        using 1(1) a by(simp add: min_def take_Suc_conv_app_nth T_append nth_append)
  finally have bef: "Tp init (take (Suc x) qs) (take (Suc x) Strat)
      = Tp init (take (Suc x) qs) (take (Suc x) ?Strat') + 1" .
     
  let ?interstate = "(steps init (take (Suc x) qs) (take (Suc x) Strat))"
  let ?interstate' = "(steps init (take (Suc x) qs) (take (Suc x) ?Strat'))"

  have state: "?interstate' = ?interstate"
    using 1(1) apply(simp add: take_Suc_conv_app_nth min_def)
    apply(simp add: steps_append step_def split_def) using noeffect by simp


  have "Tp init qs Strat
      = Tp init (take (Suc x) qs @ drop (Suc x) qs)  (take (Suc x) Strat @ drop (Suc x) Strat)"
        by simp
  also have " = Tp init (take (Suc x) qs) (take (Suc x) Strat)
            + Tp ?interstate (drop (Suc x) qs) (drop (Suc x) Strat)"
              apply(subst T_append2) by(simp_all)
  also have " =  Tp init (take (Suc x) qs) (take (Suc x) ?Strat')
            + Tp ?interstate' (drop (Suc x) qs) (drop (Suc x) ?Strat') + 1"
       unfolding bef state using 1(1) by(simp add: min_def nth_append)
  also have " = Tp init (take (Suc x) qs @ drop (Suc x) qs)  (take (Suc x) ?Strat' @ drop (Suc x) ?Strat') + 1"
              apply(subst T_append2) using 1(1) by(simp_all add: min_def)     
  also have " = Tp init qs ?Strat' + 1" by simp
  finally have better: "Tp init qs ?Strat' + 1 = Tp init qs Strat" by simp

  have "Tp init qs ?Strat' + 1 = Tp init qs Strat" by (fact better)
  also have " = Tp_opt init qs" by (fact opt)
  also from cInf_lower[OF isin] have "    Tp init qs ?Strat'" unfolding T_opt_def by simp
  finally show "False" using init_nempty by auto
qed


(* Gleichung 1.8 in Borodin *)
lemma umformung_OPT:
  assumes inlist: "set qs  set init"
  assumes dist: "distinct init" 
  assumes a: "Tp_opt init qs = Tp init qs Strat"
  assumes b: " length qs = length Strat"
  assumes c: "init[]"
  shows "Tp_opt init qs = 
    ((x,y){(x,y::('a::linorder)). x  set init  yset init  x<y}.
          ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
proof -
    have "Tp_opt init qs = Tp init qs Strat" by(fact a)
    also have " =
    ((x,y){(x,y::('a::linorder)). x  set init  yset init  x<y}.
          ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
          apply(rule umformung_OPT')
            apply(fact)+
            using OPT_noStupid[OF b[symmetric] a[symmetric] c] apply(simp) done
    finally show ?thesis .
qed


corollary OPT_zerlegen: 
  assumes
        dist: "distinct init"
  and c: "init[]"
    and setqsinit: "set qs  set init"
  shows "((x,y){(x,y::('a::linorder)). x  set init  yset init  x<y}. (Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})))
         Tp_opt init qs"
proof -

    have "Tp_opt init qs  {Tp init qs as |as. length as = length qs}"
    unfolding T_opt_def 
      apply(rule nn_contains_Inf)
      apply(auto) by (rule Ex_list_of_length)

    then obtain Strat where a: "Tp init qs Strat = Tp_opt init qs"
                       and b: "length Strat = length qs"
              unfolding T_opt_def by auto

  have "((x,y){(x,y). x  set init  yset init  x<y}.
       Tp_opt (Lxy init {x,y}) (Lxy qs {x, y}))  ((x,y){(x,y). x  set init  yset init  x<y}.
          ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
     apply (rule sum_mono)
     apply(auto)
     proof goal_cases
       case (1 a b)
       then have "ab" by auto 
       show ?case apply(rule T1_7[OF a b]) by(fact)+
     qed
  also from umformung_OPT[OF setqsinit dist] a b c have " = Tp init qs Strat" by auto
  also from a have " = Tp_opt init qs" by simp
  finally show ?thesis .
qed


subsection "Factoring Lemma"


lemma cardofpairs: "S  []  sorted S  distinct S  card {(x,y). x  set S  yset S  x<y} = ((length S)*(length S-1)) / 2"
proof (induct S rule: list_nonempty_induct)
  case (cons s ss)
  then have "sorted ss" "distinct ss" by auto
  from cons(2)[OF this(1) this(2)] have iH: "card {(x, y) . x  set ss  y  set ss  x < y}
    = (length ss * (length ss-1)) / 2"
    by auto

  from cons have sss: "s  set ss" by auto

  from cons have tt: "(yset (s#ss). s  y)" by auto
  with cons  have tt': "(yset ss. s < y)"
  proof -
    from sss have "(yset ss. s  y)" by auto
    with tt show ?thesis by fastforce
  qed
    
  then have "{(x, y) . x = s  y  set ss  x < y}
          = {(x, y) . x = s  y  set ss}" by auto
  also have " = {s}×(set ss)" by auto
  finally have "{(x, y) . x = s  y  set ss  x < y} = {s}×(set ss)" .
  then have "card {(x, y) . x = s  y  set ss  x < y}
          = card (set ss)" by(auto)
  also from cons distinct_card have " = length ss" by auto
  finally have step: "card {(x, y) . x = s  y  set ss  x < y} =
            length ss" .

  have uni: "{(x, y) . x  set (s # ss)  y  set (s # ss)  x < y}
      = {(x, y) . x  set ss  y  set ss  x < y}
         {(x, y) . x = s  y  set ss  x < y}"
        using tt by auto

  have disj: "{(x, y) . x  set ss  y  set ss  x < y}
         {(x, y) . x = s  y  set ss  x < y} = {}"
          using sss by(auto)
  have "card {(x, y) . x  set (s # ss)  y  set (s # ss)  x < y}
    = card ({(x, y) . x  set ss  y  set ss  x < y}
         {(x, y) . x = s  y  set ss  x < y})" using uni by auto
  also have " = card {(x, y) . x  set ss  y  set ss  x < y}
          + card {(x, y) . x = s  y  set ss  x < y}" 
       apply(rule card_Un_disjoint)
          apply(rule finite_subset[where B="(set ss) × (set ss)"])
           apply(force)
          apply(simp)
         apply(rule finite_subset[where B="{s} × (set ss)"])
          apply(force)
         apply(simp)
         using disj apply(simp) done
  also have " = (length ss * (length ss-1)) / 2
                  + length ss" using iH step by auto
  also have " = (length ss * (length ss-1) + 2*length ss) / 2" by auto
  also have " = (length ss * (length ss-1) + length ss * 2) / 2" by auto
  also have " = (length ss * (length ss-1+2)) / 2"
    by simp
  also have " = (length ss * (length ss+1)) / 2"
    using cons(1) by simp
  also have " = ((length ss+1) * length ss) / 2" by auto
  also have " = (length (s#ss) * (length (s#ss)-1)) / 2" by auto
  finally show ?case by auto
next
  case single thus ?case by(simp cong: conj_cong)
qed


(* factoring lemma *)
lemma factoringlemma_withconstant:
    fixes A
          and b::real
          and c::real
      assumes c: "c  1"
      assumes dist: "eS0. distinct e"
      assumes notempty: "eS0. length e > 0"
      (* A has pairwise property *)
      assumes pw: "pairwise A"
      (* A is c-competitive on list of length 2 *) 
      assumes on2: "s0S0. b0. qs{x. set x  set s0}. (x,y){(x,y). x  set s0  yset s0  x<y}. Tp_on_rand A (Lxy s0 {x,y}) (Lxy qs {x,y})   c * (Tp_opt (Lxy s0 {x,y}) (Lxy qs {x,y})) + b" 
      assumes nopaid: "is s q. ((free,paid),_)  (snd A (s, is) q). paid=[]"
      assumes 4: "init qs. distinct init  set qs  set init  (x. x<length qs  finite (set_pmf (config'' A qs init x)))" 
      (* then A is c-competitive on arbitrary list lengths *)
      shows "s0S0. b0.  qs{x. set x  set s0}. 
              Tp_on_rand A s0 qs  c * real (Tp_opt s0 qs) + b"
proof (standard, goal_cases)
  case (1 init)
    have d: "distinct init" using  dist 1 by auto
    have d2: "init  []" using  notempty 1 by auto


    obtain b where on3: "qs{x. set x  set init}. (x,y){(x,y). x  set init  yset init  x<y}. Tp_on_rand A  (Lxy init {x,y}) (Lxy qs {x,y})  c * (Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b"
        and b: "b0"
      using on2 1 by auto

  {

    fix qs
    assume drin: "set qs  set init"

  have "Tp_on_rand A init qs =
((x,y){(x, y) . x  set init  y  set init  x < y}.
       Tp_on_rand A (Lxy init {x,y}) (Lxy qs {x, y})) "
       apply(rule umf_pair)
        apply(fact)+
        using 4[of init qs] drin d by(simp add: split_def)
       (* 1.4 *) 
  also have "  ((x,y){(x,y). x  set init  yset init  x<y}. c * (Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b)"
        apply(rule sum_mono)
        using on3 drin by(simp add: split_def) 
  also have " = c * ((x,y){(x,y). x  set init  yset init  x<y}. Tp_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b*(((length init)*(length init-1)) / 2)"
  proof - 

    {
      fix S::"'a list"
      assume dis: "distinct S"
      assume d2: "S  []"
      then have d3: "sort S  []" by (metis length_0_conv length_sort)
      have "card {(x,y). x  set S  yset S  x<y}
            = card {(x,y). x  set (sort S)  yset (sort S)  x<y}"
            by auto
      also have " = (length (sort S) * (length (sort S) - 1)) / 2"
        apply(rule cardofpairs) using dis d2 d3 by (simp_all)
      finally have "card {(x, y) . x  set S  y  set S  x < y} =
              (length (sort S) * (length (sort S) - 1)) / 2 " .      
    }
    with d d2 have e: "card {(x,y). x  set init  yset init  x<y} = ((length init)*(length init-1)) / 2" by auto
    show ?thesis  (is "((x,y)?S. c * (?T x y) + b) = c * ?R + b*?T2")
    proof -
       have "((x,y)?S. c * (?T x y) + b) =
              c * ((x,y)?S. (?T x y)) + ((x,y)?S. b)"
              by(simp add: split_def sum.distrib sum_distrib_left)
       also have " = c * ((x,y)?S. (?T x y)) + b*?T2"
          using e by(simp add: split_def)
       finally show ?thesis by(simp add: split_def)
    qed
  qed
  also have "  c * Tp_opt init qs + (b*((length init)*(length init-1)) / 2)"
    proof -
      have "((x, y){(x, y) . x  set init 
              y  set init  x < y}. Tp_opt (Lxy init {x,y}) (Lxy qs {x, y}))
                Tp_opt init qs"
              using OPT_zerlegen drin d d2 by auto    
      then have "  real ((x, y){(x, y) . x  set init 
              y  set init  x < y}. Tp_opt (Lxy init {x,y}) (Lxy qs {x, y}))
                  (Tp_opt init qs)"
                  by linarith
      with c show ?thesis by(auto simp: split_def)
    qed
  finally have f: "Tp_on_rand A init qs  c * real (Tp_opt init qs) + (b*((length init)*(length init-1)) / 2)" .
  } note all=this
  show ?case unfolding compet_def
    apply(auto)
      apply(rule exI[where x="(b*((length init)*(length init-1)) / 2)"])
      apply(safe)
        using notempty 1 b apply simp
        using all b by simp
qed

lemma factoringlemma_withconstant':
    fixes A
          and b::real
          and c::real
      assumes c: "c  1"
      assumes dist: "eS0. distinct e"
      assumes notempty: "eS0. length e > 0"
      (* A has pairwise property *)
      assumes pw: "pairwise A"
      (* A is c-competitive on list of length 2 *) 
      assumes on2: "s0S0. b0. qs{x. set x  set s0}. (x,y){(x,y). x  set s0  yset s0  x<y}. Tp_on_rand A (Lxy s0 {x,y}) (Lxy qs {x,y})   c * (Tp_opt (Lxy s0 {x,y}) (Lxy qs {x,y})) + b" 
      assumes nopaid: "is s q. ((free,paid),_)  (snd A (s, is) q). paid=[]"
      assumes 4: "init qs. distinct init  set qs  set init  (x. x<length qs  finite (set_pmf (config'' A qs init x)))" 
      (* then A is c-competitive on arbitrary list lengths *)
      shows "compet_rand A c S0"
unfolding compet_rand_def static_def using factoringlemma_withconstant[OF assms] by simp

 
end

Theory TS

(*  Title:       Competitive Analysis of TS
    Author:      Max Haslbeck
*) 

section "TS: another 2-competitive Algorithm"

theory TS
imports
OPT2
Phase_Partitioning
Move_to_Front 
List_Factoring
RExp_Var 
begin
 

 
subsection "Definition of TS"
 

  
definition TS_step_d where
"TS_step_d s q = ((
      ( 
        let li = index (snd s) q in
        (if li = length  (snd s) then 0 ― ‹requested for first time›
        else (let sincelast = take li  (snd s)
          in (let S={x. x < q in (fst s)  count_list sincelast x  1}
            in
             (if S={} then 0
             else
              (index (fst s) q) - Min ( (index (fst s)) ` S)))
            )
        )      
      )
      ,[]), q#(snd s))"

 
(* FIXME: generalizing regular expressions equivalence checking 
          enables relaxing the type here to 'a::linord *)
definition rTS :: "nat list  (nat,nat list) alg_on"   where "rTS h = ((λs. h), TS_step_d)"

fun TSstep where
  "TSstep qs n (is,s) 
      = ((qs!n)#is, 
        step s (qs!n) (( 
          let li = index is (qs!n) in
          (if li = length is then 0 ― ‹requested for first time›
          else (let sincelast = take li is
            in (let S={x. x < (qs!n) in s  count_list sincelast x  1}
              in
               (if S={} then 0
               else
                (index s (qs!n)) - Min ( (index s) ` S)))
              )
          )
          ),[]))"

lemma TSnopaid: "(snd (fst (snd (rTS initH) is q))) = []"
unfolding rTS_def by(simp add: TS_step_d_def)


abbreviation TSdet where
  "TSdet init initH qs n == config (rTS initH) init (take n qs)"
   
lemma TSdet_Suc: "Suc n  length qs  TSdet init initH qs (Suc n) = Step (rTS initH) (TSdet init initH qs n) (qs!n)"
by(simp add: take_Suc_conv_app_nth config_snoc)

(* now do the proof with TSdet *)

definition s_TS where "s_TS init initH qs n  = fst (TSdet init initH qs n)"

lemma sndTSdet: "nlength xs  snd (TSdet init initH xs n) = rev (take n xs) @ initH"
apply(induct n)
  apply(simp add: rTS_def)
  by(simp add: split_def TS_step_d_def take_Suc_conv_app_nth config'_snoc Step_def rTS_def)
  

subsection "Behaviour of TS on lists of length 2"

lemma 
  fixes hs x y
  assumes "xy"
  shows oneTS_step :    "TS_step_d ([x, y], x#y#hs)     y = ((1, []), y # x # y # hs)"
    and oneTS_stepyyy:  "TS_step_d ([x, y], y#x#hs)     y = ((Suc 0, []), y#y#x#hs)"
    and oneTS_stepx:    "TS_step_d ([x, y], x#x#hs)     y = ((0, []), y # x # x # hs)"
    and oneTS_stepy:    "TS_step_d ([x, y], [])         y = ((0, []), [y])"
    and oneTS_stepxy:   "TS_step_d ([x, y], [x])        y = ((0, []), [y, x])"
    and oneTS_stepyy:   "TS_step_d ([x, y], [y])        y = ((Suc 0, []), [y, y])"
    and oneTS_stepyx:   "TS_step_d ([x, y], hs)         x = ((0, []), x # hs)"
    using assms by(auto simp add: step_def mtf2_def swap_def TS_step_d_def before_in_def) 
   
lemmas oneTS_steps = oneTS_stepx oneTS_stepxy oneTS_stepyx oneTS_stepy oneTS_stepyy oneTS_stepyyy oneTS_step

subsection "Analysis of the Phases"

definition "TS_inv c x i  (hs. c = return_pmf ((if x=hd i then i else rev i),[x,x]@hs) )
                       c = return_pmf ((if x=hd i then i else rev i),[])"

lemma TS_inv_sym: "ab  {a,b}={x,y}  z{x,y}  TS_inv c z [a,b] = TS_inv c z [x,y]"
  unfolding TS_inv_def by auto

abbreviation "TS_inv' s x i == TS_inv (return_pmf s) x i"

lemma TS_inv'_det: "TS_inv' s x i = ((hs. s = ((if x=hd i then i else rev i),[x,x]@hs) )
                       s = ((if x=hd i then i else rev i),[]))"
  unfolding TS_inv_def by auto

lemma TS_inv'_det2: "TS_inv' (s,h) x i = (hs. (s,h) = ((if x=hd i then i else rev i),[x,x]@hs) )
                        (s,h) = ((if x=hd i then i else rev i),[])"
  unfolding TS_inv_def by auto

(*
TS_A   (x+1)yy →         Plus(Atom (x::nat)) One,(Atom y), (Atom y)]
TS_B   (x+1)yx(yx)*yy →  Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]
TS_C   (x+1)yx(yx)*x  →  Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]
TD_D   xx             →  seq[(Atom x),(Atom x)]
*)

subsubsection "(yx)*?"

lemma TS_yx': assumes "x  y" "qs  lang (Star(Times (Atom y) (Atom x)))"
      "hs. h=[x,y]@hs"
   shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs + T_on' (rTS h0) ([x,y],((rev qs) @h))  r
         (hs. ((rev qs) @h) = [x, y] @ hs)
         config' (rTS h0) ([x, y],h) qs = ([x,y],rev qs @ h)"
proof -
  from assms have "qs  star ({[y]} @@ {[x]})" by (simp)
  from this assms(3) show ?thesis
  proof (induct qs arbitrary: h rule: star_induct)
    case Nil
    then show ?case by(simp add: rTS_def)
  next
    case (append u v)
    then have uyx: "u = [y,x]" by auto
    from append obtain hs where a: "h = [x,y]@hs" by blast
     
    have "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r
         (hs. rev v @ (rev u @ h) = [x, y] @ hs)
         config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))"
        apply(simp only: uyx) apply(rule append(3)) by simp
    then have yy: "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r"
          and history: "(hs. rev v @ (rev u @ h) = [x, y] @ hs)"
          and state: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))" by auto
    
    have s0: "s_TS [x, y] h [y, x] 0 = [x,y]" unfolding s_TS_def by(simp) 

    from assms(1) have hahah: " {xa. xa < y in [x, y]  count_list [x] xa  1} = {x}"
      unfolding before_in_def by auto
 


    have "config' (rTS h0) ([x, y],h) u = ([x, y], x # y # x # y # hs)"
        apply(simp add: split_def rTS_def uyx a ) 
          using assms(1) by(auto simp add: Step_def oneTS_steps step_def mtf2_def swap_def)
 
    then have s2: "config' (rTS h0) ([x, y],h) u =  ([x, y], ((rev u) @ h))"
        unfolding a uyx by simp

    have "config' (rTS h0) ([x, y], h) (u @ v) = 
            config' (rTS h0) (Partial_Cost_Model.config' (rTS h0) ([x, y], h) u) v" by (rule config'_append2)
  also
    have " = config' (rTS h0)  ([x, y], ((rev u) @ h)) v" by(simp only: s2)
  also
    have " = ([x, y], rev (u @ v) @ h)" by (simp add: state)
  finally
    have alles: "config' (rTS h0) ([x, y], h) (u @ v) = ([x, y], rev (u @ v) @ h)" .
         

    have ta: "T_on' (rTS h0) ([x,y],h) u = 2"
        unfolding rTS_def uyx a apply(simp only: T_on'.simps(2))
          using assms(1) apply(auto simp add: Step_def step_def mtf2_def swap_def oneTS_steps) 
            by(simp add: tp_def) 

  

    have "T_on' (rTS h0) ([x,y],h) ((u @ v) @ r)
            = T_on' (rTS h0) ([x,y],h) (u @ (v @ r))" by auto
    also have "
        = T_on' (rTS h0) ([x,y],h) u
            + T_on' (rTS h0) (config' (rTS h0) ([x, y],h) u) (v @ r)"
        by(rule T_on'_append)
    also have " = T_on' (rTS h0) ([x,y],h) u
          + T_on' (rTS h0) ([x, y],(rev u @ h)) (v @ r)" by(simp only: s2) 
    also have " = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: yy) 
    also have " = 2 + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: ta) 
    also have " = length (u @ v) + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" using uyx by auto
    also have " = length (u @ v) + T_on' (rTS h0) ([x, y], (rev (u @ v) @ h)) r" by auto
    finally show ?case using history alles by simp   
  qed
qed

subsubsection "?x"


lemma TS_x': "T_on' (rTS h0) ([x,y],h) [x] = 0  config' (rTS h0) ([x, y],h) [x] = ([x,y], rev [x] @ h)"
by(auto simp add: tp_def rTS_def TS_step_d_def Step_def step_def)
 
subsubsection "?yy"
 
lemma TS_yy': assumes "x  y" "hs. h = [x, y] @ hs"
  shows "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
proof -
  from assms obtain hs where a: "h = [x,y]@hs" by blast 

  from a show "T_on' (rTS h0) ([x,y],h) [y, y] = 1"
      unfolding rTS_def 
        using assms(1) apply(auto simp add: oneTS_steps Step_def step_def mtf2_def swap_def)
           by(simp add: tp_def)   

  show "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
    unfolding rTS_def a using assms(1)
      by(simp add: Step_def oneTS_steps step_def mtf2_def swap_def) 
qed

subsubsection "yx(yx)*?"
 
lemma TS_yxyx': assumes [simp]: "x  y" and "qs  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
  "(hs. h=[x,x]@hs)  index h y = length h"
  shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r 
         (hs. (rev qs @ h) = [x, y] @ hs)
             config' (rTS h0) ([x, y],h) qs = ([x,y], rev qs @ h)"
proof - 
  obtain u v where uu: "u  lang (Times (Atom y) (Atom x))"
                      and vv: "v  lang (seq[ Star(Times (Atom y) (Atom x))])"
                      and qsuv: "qs = u @ v" 
                      using assms(2)
                      by (auto simp: conc_def)  
  from uu have uyx: "u = [y,x]" by(auto)

  from qsuv uyx have vqs: "length v = length qs - 2" by auto
  from qsuv uyx  have vqs2: "length v + 1 = length qs - 1" by auto

  have firststep: "TS_step_d ([x, y], h) y = ((0, []), y # h)"
  proof (cases "index h y = length h")
    case True
    then show ?thesis unfolding TS_step_d_def by(simp)
  next
    case False
    with assms(3) obtain hs where a: "h = [x,x]@hs" by auto
    then show ?thesis by(simp add: oneTS_steps) 
  qed

  have s2: "config' (rTS h0) ([x,y],h) u = ([x, y], x # y # h)"
    unfolding rTS_def uyx apply(simp add: )
    unfolding Step_def by(simp add: firststep step_def oneTS_steps) 
  
  have ta: "T_on' (rTS h0) ([x,y],h) u = 1"
    unfolding rTS_def uyx
      apply(simp)
      apply(simp add: firststep)
        unfolding Step_def                 
          using assms(1) by (simp add: firststep step_def oneTS_steps tp_def) 
 
  have ttt: 
    "T_on' (rTS h0) ([x,y],rev u @ h) (v@r) = length v + T_on' (rTS h0) ([x,y],((rev v) @(rev u @ h)))  r
       (hs. ((rev v) @(rev u @ h)) = [x, y] @ hs)
       config' (rTS h0) ([x, y],(rev u @ h)) v = ([x,y],rev v @ (rev u @ h))"
      apply(rule TS_yx')
    apply(fact)     
    using vv apply(simp)
    using uyx by(simp) 
  then have tat: "T_on' (rTS h0) ([x,y], x # y # h) (v@r) = 
          length v + T_on' (rTS h0) ([x,y],rev qs @ h)  r" 
        and history:  "(hs. (rev qs @ h) = [x, y] @ hs)"                                
        and state: "config' (rTS h0) ([x, y], x # y # h) v = ([x,y],rev qs @ h)" using qsuv uyx
        by auto
    
  have "config' (rTS h0) ([x, y], h) qs = config' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
    unfolding qsuv by (rule config'_append2)
also
  have " = ([x, y], rev qs @ h)" by(simp add: s2 state) 
finally
  have his: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)" .

 
  have "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],h) (u @ v @ r)" using qsuv  by auto
  also have "
      = T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) (config' (rTS h0) ([x,y],h) u) (v @ r)"
      by(rule T_on'_append) 
  also have " = T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) ([x, y], x # y # h) (v @ r)" by(simp only: s2) 
  also have " = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by (simp only: tat) 
  also have " = 1 + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by(simp only: ta) 
  also have " = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r" using vqs2 by auto
  finally show ?thesis 
    apply(safe)
    using history apply(simp)
    using his by auto                           
qed

 
 

lemma TS_xr': assumes "x  y" "qs  lang (Plus (Atom x) One)"
   "h = []  (hs. h = [x, x] @ hs) "
  shows "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],rev qs@h) r"
          "((hs. (rev qs @ h) = [x, x] @ hs)  (rev qs @ h) = [x]  (rev qs @ h)=[]) " 
            "config' (rTS h0) ([x,y],h) (qs@r) = config' (rTS h0) ([x,y],rev qs @ h) r"
    using assms
    by (auto simp add: T_on'_append Step_def rTS_def TS_step_d_def step_def tp_def) 

subsubsection "(x+1)yx(yx)*yy"

lemma ts_b': assumes "x  y"
  "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
  "(hs. h = [x, x] @ hs)  h = [x]  h = []"
  shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
              (hs. (rev v @ h) = [y,y]@hs)  config' (rTS h0) ([x,y], h) v = ([y,x], rev v @ h)"
proof -  
  from assms have lenvmod: "length v mod 2 = 0" apply(simp)
  proof -
    assume "v  ({[y]} @@ {[x]}) @@ star ({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}"
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r  {[y]} @@ {[y]}" by (metis concE)
    then have "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length v = 4+length q" by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show ?thesis by auto
  qed

  with assms(1,3) have fall: "(hs. h = [x, x] @ hs)  index h y = length h"
    by(auto)

  from assms(2) have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b  lang (seq[Atom y, Atom y])"
                      and vab: "v = a @ b" 
                      by(erule concE) 
  then have bb: "b=[y,y]" by auto
  from aa have lena: "length a > 0" by auto
 
  from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
    length a - 1 + T_on' (rTS h0) ([x, y], rev a @ h) b" 
    and history: "(hs. rev a @ h = [x, y] @ hs)"
    and state: "config' (rTS h0) ([x, y], h) a = ([x,y],rev a @ h)" by auto 
 (* "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)" *)
  have suffix: "T_on' (rTS h0) ([x, y], rev a @ h) b = 1"                                                       
     and jajajaj: "config' (rTS h0) ([x, y],rev a @ h) b = ([y,x],rev b @ rev a @ h)" unfolding bb 
    using TS_yy' history assms(1) by auto

  from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a" using lena by auto
  then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto
    

  have grgr:"config' (rTS h0) ([x, y], h) v = ([y, x], rev v @ h)"
     unfolding vab 
      apply(simp only: config'_append2 state jajajaj) by simp 

  from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
  then obtain hs2 where reva: "rev a @ h = x # hs2" by auto

  show ?thesis using whatineed grgr
    by(auto simp add: reva vab bb) 
qed
 
lemma TS_b'1: assumes "x  y" "h = []  (hs. h = [x, x] @ hs)"
   "qs  lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)
        TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof - 
  have f: "qs  lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
    using assms(3) by(simp add: conc_assoc)

  from ts_b'[OF assms(1) f] assms(2) have
              T_star: "T_on' (rTS h0) ([x, y], h) qs = length qs - 2"
          and inv1:   "config' (rTS h0) ([x, y],  h) qs = ([y, x], rev qs @ h)"
          and inv2:   "(hs. rev qs @ h = [y, y] @ hs)" by auto

  from T_star have TS: "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)" by metis
  
  have lqs: "last qs = y" using assms(3) by force
 

  from inv1 have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
    apply(simp add: lqs)         
      apply(subst TS_inv'_det)
      using assms(2) inv2  by(simp)


  show ?thesis unfolding TS
    apply(safe) 
      by(fact inv)
qed



lemma TS_b1'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}"  
   "qs  lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto
  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        and B: "qs  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
        and C: "h = []  (hs. h = [x, x] @ hs)"
    
    then have C': "(hs. h = [x, x] @ hs)  h = [x]  h = []" by blast
    from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)
    
    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using ts_b'[OF A B C'] A lqs unfolding TS_inv'_det by auto
  } note b1=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule b1)
        using assms apply(simp)
        using assms apply(simp add: conc_assoc)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule b1)
          using assms apply(simp)
          using assms apply(simp add: conc_assoc)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed

         
lemma ts_b2': assumes "x  y"
  "qs  lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
  "(hs. h = [x, x] @ hs)  h = []"
  shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
              config' (rTS h0) ([x,y], h) qs = ([y,x],rev qs@h)  (hs. (rev qs @ h) = [y,y]@hs)"
proof -
  from assms(2) obtain v where qs: "qs = [x]@v"
          and V: "vlang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
          by(auto simp add: conc_assoc)  
 
  from assms(3) have 3: "(hs. x#h = [x, x] @ hs)  x#h = [x]  x#h = []" by auto

  from ts_b'[OF assms(1) V 3]
    have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
    and C: "config' (rTS h0) ([x, y], x#h) v = ([y, x], rev v @ x#h)"
    and H: "(hs. rev v @ x#h = [y, y] @ hs)" by auto

  have t: "tp [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
      by (simp add: step_def rTS_def TS_step_d_def tp_def)
  have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
            = ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

  show ?thesis
    unfolding qs apply(safe)
      apply(simp add: T_on'_append T c t)
      apply(simp add: config'_rand_append C c)
      using H by simp
qed


lemma TS_b2'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}"  
   "qs  lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto
  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        and B: "qs  lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
        and C: "h = []  (hs. h = [x, x] @ hs)"
    
    from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)
    
    from C have C': "(hs. h = [x, x] @ hs)  h = []" by blast

    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using ts_b2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
  } note b2=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule b2)
        using assms apply(simp)
        using assms apply(simp add: conc_assoc)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule b2)
          using assms apply(simp)
          using assms apply(simp add: conc_assoc)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed



lemma TS_b': assumes "x  y" "h = []  (hs. h = [x, x] @ hs)"
   "qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "T_on' (rTS h0) ([x, y], h) qs
     2 * Tp [x, y] qs (OPT2 qs [x, y])  TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof -
  obtain u v where uu: "u  lang (Plus (Atom x) One)"
        and vv: "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
        and qsuv: "qs = u @ v" 
        using assms(3)
        by (auto simp: conc_def)   
 
  from TS_xr'[OF assms(1) uu assms(2)]  have
              T_pre: "T_on' (rTS h0) ([x, y], h) (u @ v) = 
                        T_on' (rTS h0) ([x, y], rev u @ h) v"
          and fall': "(hs. (rev u @ h) = [x, x] @ hs)  (rev u @ h) = [x]  (rev u @ h)=[]"
          and conf: "config' (rTS h0) ([x,y],h) (u@v) = config' (rTS h0) ([x,y],rev u @ h) v"
            by auto
          
  with assms uu have fall: "(hs. (rev u @ h) = [x, x] @ hs)  index (rev u @ h) y = length (rev u @ h)"
    by(auto) 

  from ts_b'[OF assms(1) vv fall'] have
              T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = length v - 2"
          and inv1:   "config' (rTS h0) ([x, y], rev u @ h) v = ([y, x], rev v @ rev u @ h)"
          and inv2:   "(hs. rev v @ rev u @ h = [y, y] @ hs)" by auto

  from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

  (* OPT *)

  from uu have uuu: "u=[]  u=[x]" by auto
  from vv have vvv: "v  lang (seq
          [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto simp: conc_def)
  have OPT: "Tp [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+
 
  have lqs: "last qs = y" using assms(3) by force

  have "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
    unfolding qsuv conf inv1 by simp

  then have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
    apply(simp add: lqs)         
      apply(subst TS_inv'_det)
      using assms(2) inv2 qsuv by(simp)


  show ?thesis unfolding TS OPT
    apply(safe)
      apply(simp)
      by(fact inv)
qed


subsubsection "(x+1)yy"


lemma ts_a': assumes "x  y" "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
   "h = []  (hs. h = [x, x] @ hs)"
  shows "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]
           T_on' (rTS h0) ([x, y], h) qs = 2"
proof - 
  obtain u v where uu: "u  lang (Plus (Atom x) One)"
        and vv: "v  lang (seq[Atom y, Atom y])"
        and qsuv: "qs = u @ v" 
        using assms(2)
        by (auto simp: conc_def)  

  from vv have vv2: "v = [y,y]" by auto 

  from uu have TS_prefix: " T_on' (rTS h0) ([x, y], h) u = 0"
   using assms(1) by(auto simp add: rTS_def oneTS_steps tp_def)    

  have h_split: "rev u @ h = []  rev u @ h = [x]  ( hs. rev u @ h = [x,x]@hs)"
    using assms(3) uu by(auto)

  then have e: "T_on' (rTS h0) ([x,y],rev u @ h) [y,y] = 2"
      using assms(1)                    
      apply(auto simp add: rTS_def
              oneTS_steps
              Step_def step_def tp_def) done
        
  have conf: "config' (rTS h0) ([x, y], h) u = ([x,y], rev u @ h)"
    using uu by(auto simp add: Step_def rTS_def TS_step_d_def step_def)

  have "T_on' (rTS h0) ([x, y], h) qs = T_on' (rTS h0) ([x, y], h) (u @ v)" using qsuv  by auto
  also have "
      =T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
      by(rule T_on'_append)
  also have "
      = T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) ([x,y],rev u @ h) [y,y]"
        by(simp add: conf vv2)
  also have " = T_on' (rTS h0) ([x, y], h) u + 2" by (simp only: e)
  also have " = 2" by (simp add: TS_prefix)
  finally have TS: "T_on' (rTS h0) ([x, y], h) qs= 2" .

  (* dannach *)
 
  have lqs: "last qs = y" using assms(2) by force

  from assms(1) have "config' (rTS h0) ([x, y], h) qs = ([y,x], rev qs @ h)"
    unfolding qsuv
    apply(simp only: config'_append2 conf vv2)
    using h_split
      apply(auto simp add: Step_def rTS_def
              oneTS_steps
              step_def)
        by(simp_all add: mtf2_def swap_def) 

  with assms(1) have "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
    apply(subst TS_inv'_det)
      by(simp add: qsuv vv2 lqs)
 
  show ?thesis unfolding TS apply(auto) by fact
qed

lemma TS_a': assumes  "x  y"
    "h = []  (hs. h = [x, x] @ hs)"
  and "qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])"
  shows "T_on' (rTS h0) ([x, y], h) qs  2 * Tp [x, y] qs (OPT2 qs [x, y])
     TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]
     T_on' (rTS h0) ([x, y], h) qs = 2"
proof -      
  have OPT: "Tp [x,y] qs (OPT2 qs [x,y]) = 1" using OPT2_A[OF assms(1,3)] by auto
  show ?thesis using OPT ts_a'[OF assms(1,3,2)] by auto  
qed 

lemma TS_a'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}" "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
 shows  
    "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       Tp_on_rand' (embed (rTS h0)) s qs = 2" 
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto

  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        "qs  lang (seq [question (Atom x), Atom y, Atom y])"
        "h = []  (hs. h = [x, x] @ hs)"
     
    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 2"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using ts_a'[OF A] by auto
  } note b=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule b)
        using assms apply(simp)
        using assms apply(simp)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule b)
          using assms apply(simp)
          using assms apply(simp)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed

subsubsection "x+yx(yx)*x"

lemma ts_c': assumes "x  y"
  "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
  "(hs. h = [x, x] @ hs)  h = [x]  h = []"
  shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
              config' (rTS h0) ([x,y], h) v = ([x,y],rev v@h)  (hs. (rev v @ h) = [x,x]@hs)"
proof -
  from assms have lenvmod: "length v mod 2 = 1" apply(simp)
  proof -
    assume "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}"
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r  {[x]}" by (metis concE)
    then have "p = [y,x]" "r=[x]" by auto
    with pqr have a: "length v = 3+length q" by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show "length v mod 2 = Suc 0" by auto
  qed

  with assms(1,3) have fall: "(hs. h = [x, x] @ hs)  index h y = length h"
    by(auto) 

  

  from assms(2) have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom x])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b  lang (seq[Atom x])"
                      and vab: "v = a @ b" 
                      by(erule concE) 
  then have bb: "b=[x]" by auto
  from aa have lena: "length a > 0" by auto
 
  from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
    length a - 1 + T_on' (rTS h0) ([x, y],rev a @ h) b"
    and history: "(hs. rev a @ h = [x, y] @ hs)"
    and state: "config' (rTS h0) ([x, y], h) a =  ([x, y], rev a @ h)" by auto


  have suffix: "T_on' (rTS h0) ( [x, y],rev a @ h) b = 0"
          and suState: "config' (rTS h0) ([x, y], rev a @ h) b = ([x,y], rev b @ (rev a @ h))"
    unfolding bb using TS_x' by auto 

  from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a - 1" by auto
  then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto

  have conf: "config' (rTS h0) ([x, y], h) v = ([x, y], rev v @ h)" 
    by(simp add: vab config'_append2 state suState) 

 
  from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
  then obtain hs2 where reva: "rev a @ h = x # hs2" by auto


  show ?thesis using whatineed
    apply(auto) 
      using conf apply(simp)
      by(simp add: reva vab bb)
qed


lemma TS_c1'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}"  
   "qs  lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
 shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto
  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        and B: "qs  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
        and C: "h = []  (hs. h = [x, x] @ hs)"
    
    then have C': "(hs. h = [x, x] @ hs)  h = [x]  h = []" by blast
    from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)
    
    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using ts_c'[OF A B C'] A lqs unfolding TS_inv'_det by auto
  } note c1=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule c1)
        using assms apply(simp)
        using assms apply(simp add: conc_assoc)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule c1)
          using assms apply(simp)
          using assms apply(simp add: conc_assoc)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed
         
lemma ts_c2': assumes "x  y"
  "qs  lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
  "(hs. h = [x, x] @ hs)  h = []"
  shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
              config' (rTS h0) ([x,y], h) qs = ([x,y],rev qs@h)  (hs. (rev qs @ h) = [x,x]@hs)"
proof -
  from assms(2) obtain v where qs: "qs = [x]@v"
          and V: "vlang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
          by(auto simp add: conc_assoc)  
 
  from assms(3) have 3: "(hs. x#h = [x, x] @ hs)  x#h = [x]  x#h = []" by auto

  from ts_c'[OF assms(1) V 3]
    have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
    and C: "config' (rTS h0) ([x, y], x#h) v = ([x, y], rev v @ x#h)"
    and H: "(hs. rev v @ x#h = [x, x] @ hs)" by auto

  have t: "tp [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
      by (simp add: step_def rTS_def TS_step_d_def tp_def)
  have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
            = ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

  show ?thesis
    unfolding qs apply(safe)
      apply(simp add: T_on'_append T c t)
      apply(simp add: config'_rand_append C c)
      using H by simp
qed


lemma TS_c2'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}"  
   "qs  lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
 shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto
  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        and B: "qs  lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
        and C: "h = []  (hs. h = [x, x] @ hs)"
    
    from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)
    
    from C have C': "(hs. h = [x, x] @ hs)  h = []" by blast

    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using ts_c2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
  } note c2=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule c2)
        using assms apply(simp)
        using assms apply(simp add: conc_assoc)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule c2)
          using assms apply(simp)
          using assms apply(simp add: conc_assoc)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed


lemma TS_c': assumes "x  y" "h = []  (hs. h = [x, x] @ hs)"
  "qs  lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
  shows "T_on' (rTS h0) ([x, y], h) qs
     2 * Tp [x, y] qs (OPT2 qs [x, y])   TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof -
  obtain u v where uu: "u  lang (Plus (Atom x) One)"
        and vv: "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
        and qsuv: "qs = u @ v" 
        using assms(3)
        by (auto simp: conc_def)   
 
  from TS_xr'[OF assms(1) uu assms(2)] have
              T_pre: "T_on' (rTS h0) ([x, y], h) (u@v) = T_on' (rTS h0) ([x, y], rev u @ h) v"
          and fall': "(hs. (rev u @ h) = [x, x] @ hs)  (rev u @ h) = [x]  (rev u @ h)=[]"
          and conf': "config' (rTS h0) ([x, y], h) (u @ v) =
                config' (rTS h0) ([x, y], rev u @ h) v" by auto
      
  with assms uu have fall: "(hs. (rev u @ h) = [x, x] @ hs)  index (rev u @ h) y = length (rev u @ h)"
    by(auto) 

  from ts_c'[OF assms(1) vv fall'] have
              T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = (length v - 2)"
          and inv1:   "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ rev u @ h)"
          and inv2:   "(hs. rev v @ rev u @ h = [x, x] @ hs)" by auto

  from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

  (* OPT *)

  from uu have uuu: "u=[]  u=[x]" by auto
  from vv have vvv: "v  lang (seq
          [Atom y, Atom x,
           Star (Times (Atom y) (Atom x)),
           Atom x])" by(auto simp: conc_def)
  have OPT: "Tp [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+
     
  have lqs: "last qs = x" using assms(3) by force

  have conf: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)"
    by(simp add: qsuv conf' inv1)
  then have conf: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
    apply(simp add: lqs)
      apply( subst TS_inv'_det)
       using inv2 qsuv by(simp)
 
  show ?thesis unfolding TS OPT
    by (auto simp add: conf) 
qed



subsubsection "xx"

lemma request_first: "xy  Step (rTS h) ([x, y], is) x = ([x,y],x#is)"
unfolding rTS_def Step_def by(simp add: split_def TS_step_d_def step_def)

lemma ts_d': "qs  Lxx x y 
    x  y 
    h = []  (hs. h = [x, x] @ hs) 
    qs  lang (seq [Atom x, Atom x]) 
    T_on' (rTS h0) ([x, y], h) qs = 0 
     TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x,y]"
proof -
  assume xny: "x  y"
  assume "qs  lang (seq [Atom x, Atom x])"
  then have xx: "qs = [x,x]" by auto

  from xny have TS: "T_on' (rTS h0) ([x, y], h) qs = 0" unfolding xx
      by(auto simp add: Step_def step_def oneTS_steps rTS_def  tp_def) 

  from xny have "config' (rTS h0) ([x, y], h) qs = ([x, y], x # x # h) "
    by(auto simp add: xx Step_def rTS_def oneTS_steps step_def)
      
  then have " TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x, y]"
    by(simp add: TS_inv'_det)
      
  with TS  show ?thesis by simp  
qed



lemma TS_d': assumes xny: "x  y" and "h = []  (hs. h = [x, x] @ hs)"
    and qsis: "qs  lang (seq [Atom x, Atom x])"
    shows "T_on' (rTS h0) ([x,y],h) qs  2 * Tp [x, y] qs (OPT2 qs [x, y]) "
      and "TS_inv' (config' (rTS h0) ([x,y],h) qs)  (last qs) [x, y]"
      and "T_on' (rTS h0) ([x,y],h) qs = 0"
proof -
  from qsis have xx: "qs = [x,x]" by auto

  show TS: "T_on' (rTS h0) ([x,y],h) qs = 0"  
    using assms(1) by (auto simp add: xx tp_def rTS_def Step_def oneTS_steps step_def) 
  then show "T_on' (rTS h0) ([x,y],h) qs  2 * Tp [x, y] qs (OPT2 qs [x, y])" by simp

  show "TS_inv' (config' (rTS h0) ([x,y],h) qs)  (last qs) [x, y]"
    unfolding TS_inv_def
      by(simp add: xx request_first[OF xny]) 
qed


lemma TS_d'': assumes 
    "x  y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
    "set qs  {x, y}"  
   "qs  lang (seq [Atom x, Atom x])"
 shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
       T_on_rand' (embed (rTS h0)) s qs = 0"
proof -
  from assms(1,2) have kas: "(x0=x  y0=y)  (y0=x  x0=y)" by(auto)
  then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = []  (hs. h = [x, x] @ hs)"
    apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto) 
  
  have l: "qs  []" using assms by auto
  {
    fix x y qs h0
    fix h:: "nat list"
    assume A: "x  y"
        and B: "qs  lang (seq [Atom x, Atom x])"
        and C: "h = []  (hs. h = [x, x] @ hs)"
    
    from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)
     

    have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] 
            T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 0"
      apply(simp only: T_on'_embed[symmetric] config'_embed)
      using TS_d'[OF A C B ] A lqs unfolding TS_inv'_det by auto
  } note d=this
   

  show ?thesis unfolding S 
    using kas apply(rule disjE)
      apply(simp only:)
      apply(rule d)
        using assms apply(simp)
        using assms apply(simp add: conc_assoc)
        using h apply(simp)
      apply(simp only:)
      
      apply(subst TS_inv_sym[of y x x y])
        using assms(1) apply(simp)
        apply(blast)
        defer
        apply(rule d)
          using assms apply(simp)
          using assms apply(simp add: conc_assoc)
          using h apply(simp)
        using last_in_set l assms(4) by blast
qed



subsection "Phase Partitioning"
 
lemma D': assumes "σ'  Lxx x y" and "x  y" and "TS_inv' ([x, y], h) x [x, y]"
  shows  "T_on' (rTS h0) ([x, y], h) σ'  2 * Tp [x, y] σ' (OPT2 σ' [x, y]) 
        TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ') (last σ') [x, y]"
proof -

  from config'_embed have " config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ' 
      = return_pmf (Partial_Cost_Model.config' (rTS h0) ([x, y], h) σ')" by blast

  then have L: "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ') (last σ') [x, y]
      = TS_inv' (config' (rTS h0) ([x, y], h) σ')  (last σ') [x, y]" by auto
 
  from assms(3) have 
      h: "h = []  (hs. h = [x, x] @ hs)"
      by(auto simp add: TS_inv'_det) 

  have "T_on' (rTS h0) ([x, y], h) σ'  2 * Tp [x, y] σ' (OPT2 σ' [x, y]) 
        TS_inv' (config' (rTS h0) ([x, y], h) σ')  (last σ') [x, y]"  
  apply(rule LxxE[OF assms(1)])
    using TS_d'[OF assms(2) h, of "σ'"] apply(simp)
    using TS_b'[OF assms(2) h] apply(simp)
    using TS_c'[OF assms(2) h] apply(simp)
    using TS_a'[OF assms(2) h] apply fast
    done 

  then show ?thesis using L by auto
qed

theorem TS_OPT2':  "(x::nat)  y  set σ  {x,y}
      Tp_on (rTS []) [x,y] σ   2 * real (Tp_opt [x,y] σ) + 2"
apply(subst T_on_embed)   
  apply(rule Phase_partitioning_general[where P=TS_inv])
      apply(simp)
     apply(simp)
    apply(simp)
   apply(simp add: TS_inv_def rTS_def) 
  proof (goal_cases)
    case (1 a b σ' s)
    from 1(6) obtain h hist' where s: "s = return_pmf ([a, b], h)" 
            and "h = []  h = [a,a]@hist'"
      unfolding TS_inv_def apply(cases "a=hd [x,y]")
        apply(simp) using 1 apply fast
        apply(simp) using 1 by blast
         
    from 1 have xyab: "TS_inv' ([a, b], h) a [x, y]
          = TS_inv' ([a, b], h) a [a, b]"
           by(auto simp add: TS_inv'_det)

    with 1(6) s have inv: "TS_inv' ([a, b], h) a [a, b]" by simp

    from σ'  Lxx a b have "σ'  []" using Lxx1 by fastforce
    then have l: "last σ'  {x,y}" using 1(5,7) last_in_set by blast

    show ?case unfolding s T_on'_embed[symmetric]
      using D'[OF 1(3,4) inv, of "[]"]
        apply(safe)
         apply linarith
        using TS_inv_sym[OF 1(4,5)] l apply blast 
       done
  qed
  
subsection "TS is pairwise"

 

lemma config'_distinct[simp]: 
  shows "distinct (fst (config' A S qs)) = distinct (fst S)" 
apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def distinct_step)

lemma config'_set[simp]: 
  shows "set (fst (config' A S qs)) = set (fst S)" 
apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def set_step)
 
lemma s_TS_append: "ilength as s_TS init h (as@bs) i = s_TS init h as i"
by (simp add: s_TS_def)

lemma s_TS_distinct: "distinct init  i<length qs  distinct (fst (TSdet init h qs i))"
by(simp_all add: config_config_distinct)

lemma othersdontinterfere: "distinct init  i < length qs  aset init  bset init
      set qs  set init  qs!i{a,b}  a < b in s_TS init h qs i  a < b in s_TS init h qs (Suc i)"
apply(simp add: s_TS_def split_def take_Suc_conv_app_nth config_append Step_def step_def)
  apply(subst x_stays_before_y_if_y_not_moved_to_front)
    apply(simp_all add: config_config_distinct config_config_set)
    by(auto simp: rTS_def TS_step_d_def) 

lemma  TS_mono:
    fixes l::nat
    assumes 1: "x < y in s_TS init h xs (length xs)"
     and l_in_cs: "l  length cs"
     and firstocc: "j<l. cs ! j  y"
     and "x  set cs" 
     and di: "distinct init"  
     and inin: "set (xs @ cs)  set init"
    shows "x < y in s_TS init h (xs@cs) (length (xs)+l)"
proof -                                               
  from before_in_setD2[OF 1] have y: "y : set init" unfolding s_TS_def by(simp add: config_config_set)
  from before_in_setD1[OF 1] have x: "x : set init" unfolding s_TS_def by(simp add: config_config_set)

  {
      fix n
      assume "nl"
      then have "x < y in s_TS init h ((xs)@cs) (length (xs)+n)"
        proof(induct n)
          case 0
          show ?case apply (simp only: s_TS_append ) using 1 by(simp) 
        next
          case (Suc n) 
          then have n_lt_l: "n<l" by auto
          show ?case apply(simp)
            apply(rule othersdontinterfere)
              apply(rule di)
              using n_lt_l l_in_cs apply(simp)
              apply(fact x)
              apply(fact y)
              apply(fact inin)
              apply(simp add: nth_append) apply(safe)
                using assms(4) n_lt_l l_in_cs apply fastforce
                using firstocc n_lt_l apply blast
                using Suc(1) n_lt_l by(simp)
        qed  
    }
    ― ‹before the request to y, x is in front of y›
    then show "x < y in s_TS init h (xs@cs) (length (xs)+l)"
      by blast
qed

lemma step_no_action: "step s q (0,[]) = s"
unfolding step_def mtf2_def by simp

lemma s_TS_set: "i  length qs  set (s_TS init h qs i) = set init"
apply(induct i)
  apply(simp add: s_TS_def  )
  apply(simp add: s_TS_def TSdet_Suc)
  by(simp add: split_def rTS_def Step_def step_def)

lemma count_notin2: "count_list xs x = 0  x  set xs"
apply (induction xs)  apply (auto del: count_notin)
  apply(case_tac "a=x") by(simp_all)+

lemma count_append: "count_list (xs@ys) x = count_list xs x + count_list ys x"
apply(induct xs) by(simp_all)

lemma count_rev: "count_list (rev xs) x = count_list xs x"
apply(induct xs) by(simp_all add: count_append )
 
lemma mtf2_q_passes: assumes "q  set xs" "distinct xs" 
  and "index xs q - n  index xs x" "index xs x < index xs q"
  shows "q < x in (mtf2 n q xs)"
proof -
  from assms have "index xs q < length xs" by auto
  with assms(4) have ind_x: "index xs x < length xs" by auto
  then have xinxs: "xset xs" using index_less_size_conv by metis 

  have B: "index (mtf2 n q xs) q = index xs q - n"
    apply(rule mtf2_q_after)
      by(fact)+
  also from ind_x mtf2_forward_effect3'[OF assms]
      have A: " < index (mtf2 n q xs) x" by auto 
  finally show ?thesis unfolding before_in_def using xinxs by force
qed
                
lemma twotox:
    assumes "count_list bs y  1"
      and "distinct init"
      and "x  set init"
      and "y : set init" 
      and "x  set bs"
      and "xy"
    shows "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
proof -
  have aa: "snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))
        = rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h"
          apply(rule sndTSdet)  by(simp)
  then have aa': "snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))
        = rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h" by auto
  have lasocc_x: "index (snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))) x = length bs"
    unfolding aa
    apply(simp add:  del: config'.simps)
    using assms(5) by(simp add: index_append) 
  then have lasocc_x': "(index (snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x) = length bs" by auto

  let ?sincelast = "take (length bs)
                          (snd (TSdet init h ((as @ x # bs) @ [x])
                                 (Suc (length as + length bs))))"
  have sl: "?sincelast  = rev bs" unfolding aa by(simp)
  let ?S = "{xa. xa < x in fst (TSdet init h (as @ x # bs @ [x])
                                      (Suc (length as + length bs))) 
                             count_list ?sincelast xa  1}"

  have y: "y  ?S  ~  y < x  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
    unfolding sl unfolding s_TS_def using assms(1) by(simp add: count_rev del: config'.simps)
 
    have eklr: "length (as@[x]@bs@[x]) = Suc (length (as@[x]@bs))" by simp
  have 1: "s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))
     = fst (Partial_Cost_Model.Step (rTS h)
          (TSdet init h (as @ [x] @ bs @ [x])
            (length (as @ [x] @ bs)))
          ((as @ [x] @ bs @ [x]) ! length (as @ [x] @ bs)))" unfolding s_TS_def unfolding eklr apply(subst TSdet_Suc)
              by(simp_all add: split_def)

  have brrr: "x set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
    apply(subst s_TS_set[unfolded s_TS_def])
      apply(simp) by fact
  have ydrin: "yset (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))" 
    apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact
  have dbrrr: "distinct (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))" 
    apply(subst s_TS_distinct[unfolded s_TS_def]) using assms(2) by(simp_all)

  show ?thesis
  proof (cases "y < x  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))")
    case True
    with y have yS: "y?S" by auto
    then have minsteps: "Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)
               index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
      by auto
    let ?entf = "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x -
                           Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)"
    from minsteps have br: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
           index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y" 
          by presburger
    have brr: "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
        < index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x"
          using True unfolding before_in_def s_TS_def by auto

    from br brr have klo: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
           index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
         index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
        < index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x" by metis
   
 
    let ?result ="(mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"

    have whatsthat: "s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))
        = ?result"   
        unfolding 1 apply(simp add: split_def step_def rTS_def Step_def TS_step_d_def del: config'.simps)
        apply(simp add: nth_append del: config'.simps)
          using lasocc_x'[unfolded rTS_def] aa'[unfolded rTS_def]
            apply(simp add:  del: config'.simps)
          using yS[unfolded sl rTS_def] by auto  


    have ydrinee: "  y  set (mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))" 
      apply(subst set_mtf2)  
      apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact

    show ?thesis unfolding whatsthat apply(rule mtf2_q_passes) by(fact)+       
  next
    case False
    then have 2: "x < y  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))" 
      using brrr ydrin not_before_in assms(6) unfolding s_TS_def by metis 
    {
      fix e
      have "x < y in mtf2 e x (s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs)))"
        apply(rule x_stays_before_y_if_y_not_moved_to_front)
          unfolding s_TS_def
          apply(fact)+
          using assms(6) apply(simp)
          using 2 unfolding s_TS_def by simp
    } note bratz=this
    show ?thesis unfolding 1 apply(simp add: TSnopaid split_def Step_def s_TS_def TS_step_d_def step_def nth_append  del: config'.simps)
            using bratz[unfolded s_TS_def] by simp  
  qed

qed

lemma count_drop: "count_list (drop n cs) x  count_list cs x"
proof -
  have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
  also have " = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
  also have "  count_list (drop n cs) x" by auto
  finally show ?thesis .
qed

lemma count_take_less: assumes "nm" 
  shows "count_list (take n cs) x  count_list (take m cs) x"
proof -
    from assms have "count_list (take n cs) x = count_list (take n (take m cs)) x" by auto
    also have "  count_list (take n (take m cs) @ drop n (take m cs)) x" by (simp only: count_append)
    also have " = count_list (take m cs) x" 
        by(simp only: append_take_drop_id)
    finally show ?thesis .
qed

lemma count_take: "count_list (take n cs) x  count_list cs x"
proof -
  have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
  also have " = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
  also have "  count_list (take n cs) x" by auto
  finally show ?thesis .
qed

lemma casexxy: assumes "σ=as@[x]@bs@[x]@cs"
    and "x  set cs"
    and "set cs  set init"
    and "x  set init"
    and "distinct init"
    and "x  set bs"
    and "set as  set init"
    and "set bs  set init"
  shows "(%i. i<length cs  (j<i. cs!jcs!i)  cs!ix
       (cs!i)  set bs
       x < (cs!i) in  (s_TS init h σ (length (as@[x]@bs@[x]) + i+1))) i"
proof (rule infinite_descent[where P="(%i. i<length cs  (j<i. cs!jcs!i)  cs!ix
       (cs!i)  set bs
       x < (cs!i) in  (s_TS init h σ (length (as@[x]@bs@[x]) + i+1)))"], goal_cases)
  case (1 i) 
  let ?y = "cs!i" 
  from 1 have i_in_cs: "i < length cs" and
      firstocc: "(j<i. cs ! j  cs ! i)"
      and ynx: "cs ! i  x"
      and ynotinbs: "cs ! i  set bs"
      and y_before_x': "~x < cs ! i in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)" by auto

  have ss: "set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)) = set init" using assms(1) i_in_cs by(simp add: s_TS_set)
  then have "cs ! i  set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1))"
    unfolding ss using assms(3) i_in_cs by fastforce
  moreover have "x : set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1))"
    unfolding ss using assms(4) by fastforce

  ― ‹after the request to y, y is in front of x›
  ultimately have y_before_x_Suct3: "?y < x in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)"
      using  y_before_x' ynx not_before_in by metis

  from ynotinbs have yatmostonceinbs: "count_list bs (cs!i)  1" by simp
 

  let ?y = "cs!i"
  have yininit: "?y  set init" using assms(3) i_in_cs by fastforce
  {
    fix y
    assume "y  set init"
    assume "xy"
    assume "count_list bs y  1"
    then have "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
      apply(rule twotox) by(fact)+
  } note xgoestofront=this    
  with yatmostonceinbs ynx yininit have zeitpunktt2: "x < ?y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))" by blast
 
  have "i  length cs" using i_in_cs by auto
  have x_before_y_t3: "x < ?y in s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+i)"
    apply(rule TS_mono)
      apply(fact)+
      using assms by simp
  ― ‹so x and y swap positions when y is requested, that means that y was inserted infront of
      some elment z (which cannot be x, has only been requested at most once since last request of y
          but is in front of x)›

  ― ‹first show that y must have been requested in as›
  
  have "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
          rev (take (length (as @ [x] @ bs @ [x]) + i) (as @ [x] @ bs @ [x] @ cs)) @ h"
            apply(rule sndTSdet) using i_in_cs by simp
  also have "  = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by simp
  finally have fstTS_t3: "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) = 
                (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" .
  then have fstTS_t3': "(snd (TSdet init h σ (Suc (Suc (length as + length bs + i))))) = 
                (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" using assms(1) by auto

  let ?is = "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
  let ?is' = "snd (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
  let ?s = "fst (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
  let ?s' = "fst (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
  let ?s_Suct3="s_TS init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i+1)" 

  let ?S = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s 
            count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) xa  1) }"
  let ?S' = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s' 
            count_list (take (index ?is' ((cs!i))) ?is') xa  1) }"

  have isis': "?is = ?is'" by(simp)
  have ss': "?s = ?s'" by(simp)
  then have SS': "?S = ?S'" using i_in_cs by(simp add: nth_append)


  (* unfold TSdet once *) 
  have once: "TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i))))
        = Step (rTS h) (configp (rTS h) init (as @ x # bs @ x # take i cs)) (cs ! i)"
    apply(subst TSdet_Suc)
      using i_in_cs apply(simp)
      by(simp add: nth_append) 

  have aha: "(index ?is (cs ! i)  length ?is) 
         ?S  {}"
  proof (rule ccontr, goal_cases)
    case 1
    then have "(index ?is (cs ! i) = length ?is)  ?S = {}" by(simp)
    then have alters: "(index ?is' (cs ! i) = length ?is')  ?S' = {}"
      apply(simp only: SS') by(simp only: isis')
    ― ‹wenn (cs ! i) noch nie requested wurde, dann kann es gar nicht nach vorne gebracht werden!
        also widerspruch mit @{text y_before_x'} 
    have "?s_Suct3 = fst (config (rTS h) init ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)))"
      unfolding s_TS_def
      apply(simp only: length_append)
        apply(subst take_append)
        apply(subst take_append)
        apply(subst take_append)
        apply(subst take_append) 
        by(simp)
    also have " =  fst (config (rTS h) init (((as @ [x] @ bs @ [x]) @ (take i cs)) @ [cs!i]))"
      using i_in_cs by(simp add: take_Suc_conv_app_nth)
    also have " = step ?s' ?y (0, [])"
      proof (cases "index ?is' (cs ! i) = length ?is'")
        case True
        show ?thesis 
          apply(subst config_append)
          using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
          apply(subst TS_step_d_def)
          apply(simp only: True[unfolded rTS_def,simplified])
          by(simp)
      next
        case False 
        with alters have S': "?S' = {}" by simp

        have 1 : "{xa. xa < cs ! i
                                 in fst (Partial_Cost_Model.config' (λs. h, TS_step_d) (init, h)
                                          (as @ x # bs @ x # take i cs)) 
                                 count_list (take (index
                (snd
                  (Partial_Cost_Model.config'
                    (λs. h, TS_step_d) (init, h)
                    (as @ x # bs @ x # take i cs)))
                (cs ! i))
                        (snd
                          (Partial_Cost_Model.config'
(λs. h, TS_step_d) (init, h)
(as @ x # bs @ x # take i cs)))) xa  1} = {}" using S' by(simp add: rTS_def nth_append)

        show ?thesis 
          apply(subst config_append)
          using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
          apply(subst TS_step_d_def)  
          apply(simp only: 1 Let_def)
          by(simp)
      qed
    finally have "?s_Suct3 = step ?s ?y (0, [])" using ss' by simp
    then have e: "?s_Suct3 = ?s" by(simp only: step_no_action)
    from x_before_y_t3 have "x < cs ! i in ?s_Suct3" unfolding e unfolding s_TS_def by simp     
    with y_before_x' show "False" unfolding assms(1) by auto
  qed  
  then have aha': "index (snd (TSdet init h (as @ x # bs @ x # cs)  (Suc (Suc (length as + length bs + i)))))
 (cs ! i) 
length (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))" 
      and
      aha2: "?S  {}" by auto
      

  from fstTS_t3' assms(1) have is_: "?is = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by auto
    
   have minlencsi: " min (length cs) i = i" using i_in_cs by linarith 

   let ?lastoccy="(index (rev (take i cs) @ x # rev bs @ x # rev as @ h) (cs ! i))"
   have "?y  set (rev (take i cs))" using firstocc by (simp add: in_set_conv_nth)
   then have lastoccy: "?lastoccy 
            i + 1 + length bs + 1" using ynx ynotinbs minlencsi by(simp add: index_append)

  (* x is not in S, because it is requested at least twice since the last request to y*)
  have x_nin_S: "x?S"
      using is_ apply(simp add: split_def nth_append del: config'.simps)
  proof (goal_cases)
    case 1
     have " count_list (take ?lastoccy (rev (take i cs))) x 
          count_list (drop (length cs - i) (rev cs)) x" by (simp add: count_take rev_take)
     also have "  count_list (rev cs) x" by(simp add: count_drop ) 
     also have " = 0" using assms(2) by(simp add: count_rev)
     finally have " count_list (take ?lastoccy (rev (take i cs))) x = 0" by auto
     have"
        2 
        count_list ([x] @ rev bs @ [x]) x " apply(simp only: count_append) by(simp)
     also have " = count_list (take (1 + length bs + 1) (x # rev bs @ x # rev as @ h)) x" by auto
     also have "  count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x"
                apply(rule count_take_less)
                    using lastoccy by linarith
     also have   "   count_list (take ?lastoccy (rev (take i cs))) x
                      + count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x" by auto
     also have " = count_list (take ?lastoccy (rev (take i cs))
                            @ take (?lastoccy - min (length cs) i)
                            (x # rev bs @ x # rev as @ h)) x"
               by(simp add: minlencsi count_append) 
     finally show ?case by presburger
  qed

  have "Min (index ?s ` ?S)  (index ?s ` ?S)" apply(rule Min_in) using aha2 by (simp_all)
  then obtain z where zminimal: "index ?s z = Min (index ?s ` ?S)"and z_in_S: "z  ?S" by auto
  then have bef: "z < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s"
          and "count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) z  1" by(blast)+ 

  with zminimal have zbeforey: "z < cs ! i in ?s"
    and zatmostonce: "count_list (take (index ?is (cs ! i)) ?is) z  1"
    and isminimal: "index ?s z = Min (index ?s ` ?S)" by(simp_all add: nth_append) 
  have elemins: "z  set ?s" unfolding before_in_def by (meson zbeforey before_in_setD1)
  then  have zininit: "z  set init"
    using i_in_cs by(simp add: s_TS_set[unfolded s_TS_def] del: config'.simps) 

  from zbeforey have zbeforey_ind: "index ?s z < index ?s ?y" unfolding before_in_def by auto
  then have el_n_y: "z  ?y" by auto

  have el_n_x: "z  x" using x_nin_S  z_in_S by blast

  (* and because it is JUST before that element, z must be before x *)
  { fix s q
    have TS_step_d2: "TS_step_d s q =
      (let Vr={x. x < q in fst s  count_list (take (index (snd s) q) (snd s)) x  1}
       in ((if index (snd s) q  length (snd s)  Vr  {}
          then index (fst s) q - Min ( (index (fst s)) ` Vr)
          else 0,[]),q#(snd s)))"
    unfolding TS_step_d_def 
    apply(cases "index (snd s) q < length (snd s)") 
     using index_le_size apply(simp split: prod.split) apply blast
    by(auto simp add: index_less_size_conv split: prod.split)
  } note alt_chara=this

  have iF: "(index (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i)
                length (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) 
               {xa. xa < cs ! i in fst (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs)) 
                    count_list
                     (take (index (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i))
                       (snd (Partial_Cost_Model.config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))))
                     xa
                     1} 
               {}) = True" using aha[unfolded rTS_def] ss' SS' by(simp add: nth_append)

  have "?s_Suct3 = fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i)))))"
    by(auto simp add: s_TS_def)
  also have " = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])"   
      apply(simp only: once[unfolded assms(1)])
      apply(simp add: Step_def split_def rTS_def del: config'.simps)  
      apply(subst alt_chara) 
      apply(simp only: Let_def )
      apply(simp only: iF)
        by(simp add: nth_append) 
  finally have "?s_Suct3 = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])" .
  with isminimal have state_dannach: "?s_Suct3 = step ?s ?y (index ?s ?y - index ?s z, [])" by presburger
    

  ― ‹so y is moved in front of z, that means:› 
  have yinfrontofz: "?y < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)"
    unfolding   assms(1) state_dannach apply(simp add: step_def del: config'.simps)
    apply(rule mtf2_q_passes)
      using i_in_cs assms(5) apply(simp_all add: s_TS_distinct[unfolded s_TS_def] s_TS_set[unfolded s_TS_def]) 
      using yininit apply(simp)
      using zbeforey_ind by simp 

  
 
           
  have yins: "?y  set ?s"  
      using i_in_cs assms(3,5)  apply(simp_all add:   s_TS_set[unfolded s_TS_def] del: config'.simps) 
      by fastforce

  have "index ?s_Suct3 ?y = index ?s z" 
    and "index ?s_Suct3 z = Suc (index ?s z)" 
    proof -
      let ?xs = "(fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
      have setxs: "set ?xs = set init"
        apply(rule  s_TS_set[unfolded s_TS_def])
          using i_in_cs by auto
      then have yinxs: "cs ! i  set  ?xs"
          apply(simp  add: setxs del: config'.simps) 
          using assms(3) i_in_cs by fastforce
      
      have distinctxs: "distinct ?xs"
        apply(rule  s_TS_distinct[unfolded s_TS_def])
          using i_in_cs assms(5) by auto
      

      let ?n = "(index
             (fst (TSdet init h (as @ x # bs @ x # cs)
                    (Suc (Suc (length as + length bs + i)))))
             (cs ! i) -
            index
             (fst (TSdet init h (as @ x # bs @ x # cs)
                    (Suc (Suc (length as + length bs + i)))))
             z)"
 
      have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n
            index ?xs ?y - ?n = index (mtf2 ?n ?y ?xs) (?xs !  index ?xs ?y )"
        apply(rule mtf2_forward_effect2) 
          apply(fact)
          apply(fact)
          by simp
          
      then have  "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n" by metis
      also have " = index ?s z" using zbeforey_ind by force
      finally have A: "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?s z" .

      have aa: "index ?xs ?y - ?n  index ?xs z" "index ?xs z < index ?xs ?y" 
        apply(simp)
          using zbeforey_ind by fastforce
 
      from mtf2_forward_effect3'[OF yinxs distinctxs aa] 
        have B: "index (mtf2 ?n ?y ?xs) z = Suc (index ?xs z)" 
          using elemins yins by(simp add: nth_append split_def del: config'.simps)

      show "index ?s_Suct3 ?y = index ?s z" 
        unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps) 
          using A yins by(simp add: nth_append  del: config'.simps)    

      show "index ?s_Suct3 z = Suc (index ?s z)"
        unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps) 
          using B yins by(simp add: nth_append  del: config'.simps)        
  qed
      
  then have are: "Suc (index ?s_Suct3 ?y) = index ?s_Suct3 z" by presburger
        




  from are before_in_def y_before_x_Suct3 el_n_x  assms(1) have z_before_x: "z < x in ?s_Suct3"
    by (metis Suc_lessI not_before_in yinfrontofz) 
 

  have xSuct3: "xset ?s_Suct3" using assms(4) i_in_cs by(simp add: s_TS_set)
  have elSuct3: "zset ?s_Suct3" using zininit i_in_cs by(simp add: s_TS_set)

  have xt3: "xset ?s " apply(subst config_config_set) by fact

  note elt3=elemins

  have z_s: "z < x in ?s"
  proof(rule ccontr, goal_cases)
    case 1
    then have "x < z in ?s" using not_before_in[OF xt3 elt3] el_n_x unfolding s_TS_def by blast
    then have "x < z in ?s_Suct3"
      apply (simp only: state_dannach)
      apply (simp only: step_def)
      apply(simp add: nth_append del: config'.simps)
      apply(rule x_stays_before_y_if_y_not_moved_to_front)
        apply(subst config_config_set) using i_in_cs assms(3) apply fastforce
        apply(subst config_config_distinct) using assms(5) apply fastforce
        apply(subst config_config_set) using assms(4) apply fastforce
        apply(subst config_config_set) using zininit apply fastforce
        using el_n_y apply(simp)
        by(simp)

    then show "False" using z_before_x not_before_in[OF xSuct3 elSuct3] by blast
  qed 


  have mind: "(index ?is (cs ! i))  i + 1 + length bs + 1 " using lastoccy 
      using i_in_cs fstTS_t3'[unfolded assms(1)] by(simp add: split_def nth_append del: config'.simps)                    
 
  have "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z=
      count_list (take (i + 1 + length bs + 1) ?is) z" unfolding is_
        using el_n_x by(simp add: minlencsi count_append ) 
  also from mind have " 
           count_list (take (index ?is (cs ! i)) ?is) z"
          by(rule count_take_less) 
  also have "  1" using zatmostonce by metis
  finally have aaa: "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z  1" .
  with el_n_x have "count_list bs z + count_list (take i cs) z  1"
    by(simp add: count_append count_rev)
  moreover have "count_list (take (Suc i) cs) z = count_list (take i cs) z" 
      using i_in_cs  el_n_y by(simp add: take_Suc_conv_app_nth count_append)
  ultimately have aaaa: "count_list bs z + count_list (take  (Suc i) cs) z  1" by simp

  have z_occurs_once_in_cs: "count_list (take (Suc i) cs) z = 1"
  proof (rule ccontr, goal_cases)
    case 1
    with aaaa have atmost1: "count_list bs z  1" and "count_list (take (Suc i) cs) z = 0" by force+
    have yeah: "z  set (take (Suc i) cs)" apply(rule count_notin2) by fact
 
    ― ‹now we know that x is in front of z after 2nd request to x, and that z is not requested any more,
        that means it stays behind x, which leads to a contradiction with @{text z_before_x}

    have xin123: "x  set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
      using i_in_cs assms(4) by(simp add: s_TS_set)
    have zin123: "z  set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"  
      using i_in_cs elemins by(simp add: s_TS_set  del: config'.simps)
 
    have "x < z in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i + 1))"
      apply(rule TS_mono)
        apply(rule xgoestofront)
          apply(fact) using el_n_x apply(simp) apply(fact)
        using i_in_cs apply(simp)
        using yeah i_in_cs length_take  nth_mem
        apply (metis Suc_eq_plus1 Suc_leI min_absorb2)
        using set_take_subset assms(2) apply fast
        using assms i_in_cs  apply(simp_all ) using set_take_subset by fast
    then have ge: "¬ z < x in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
        using not_before_in[OF zin123 xin123] el_n_x by blast 

        have " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
          = s_TS init h ((as @ [x] @ bs @ [x] @ (take (i+1) cs)) @ (drop (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" by auto
        also have "
              = s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
              apply(rule s_TS_append)
                using i_in_cs by(simp)
        finally have aaa: " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
              = s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" .

    from ge z_before_x show "False" unfolding assms(1) using aaa by auto 
  qed
  from z_occurs_once_in_cs have kinSuci: "z  set (take (Suc i) cs)" by (metis One_nat_def count_notin n_not_Suc_n)
  then have zincs: "zset cs" using set_take_subset by fast
  from z_occurs_once_in_cs  obtain k where k_def: "k=index (take (Suc i) cs) z" by blast
 
 
  then have "k=index cs z" using kinSuci by (simp add: index_take_if_set)
  then have zcsk: "z = cs!k" using zincs by simp




   have era: " cs ! index (take (Suc i) cs) z = z" using kinSuci in_set_takeD index_take_if_set by fastforce
   have ki: "k<i" unfolding k_def using kinSuci el_n_y 
    by (metis i_in_cs index_take index_take_if_set le_neq_implies_less not_less_eq_eq yes)
   have zmustbebeforex: "cs!k < x in ?s"
            unfolding k_def era by (fact z_s)
 
  ― ‹before the request to z, x is in front of z, analog zu oben, vllt generell machen?›


   ― ‹element z does not occur between t1 and position k›
   have  z_notinbs: "cs ! k  set bs"
   proof -
      from z_occurs_once_in_cs aaaa have "count_list bs z = 0" by auto
      then show ?thesis using zcsk count_notin2 by metis
   qed

   
   have "count_list bs z  1" using aaaa by linarith 
   with xgoestofront[OF zininit el_n_x[symmetric]] have xbeforez: "x < z in s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))" by auto

   obtain cs1 cs2 where v: "cs1 @ cs2 = cs" and cs1: "cs1 = take (Suc k) cs" and cs2: "cs2 = drop (Suc k) cs" by auto
  
   have z_firstocc:  "j<k.  cs ! j  cs ! k"
      and z_lastocc:  "j<i-k-1.  cs2 ! j  cs ! k" 
   proof (safe, goal_cases)
    case (1 j)  
    with ki i_in_cs have 2: "j < length (take k cs)" by auto
    have un1: "(take (Suc i) cs)!k = cs!k" apply(rule nth_take) using ki by auto
    have un2: "(take k cs)!j = cs!j" apply(rule nth_take) using 1(1) ki by auto

    from i_in_cs ki have f1: "k < length (take (Suc i) cs)" by auto 
    then have "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
      by(rule id_take_nth_drop)
    also have "(take k (take (Suc i) cs)) = take k cs" using i_in_cs ki by (simp add: min_def)
    also have "... = (take j (take k cs)) @ (take k cs)!j # (drop (Suc j) (take k cs))"
        using 2 by(rule id_take_nth_drop)
    finally have "take (Suc i) cs
            =  (take j (take k cs)) @ [(take k cs)!j] @ (drop (Suc j) (take k cs)) 
                        @ [(take (Suc i) cs)!k] @ (drop (Suc k) (take (Suc i) cs))"
                        by(simp)
    then have A: "take (Suc i) cs
            =  (take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs)) 
                        @ [cs!k] @ (drop (Suc k) (take (Suc i) cs))"
                        unfolding un1 un2 by simp
    have "count_list ((take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs)) 
                        @ [cs!k] @ (drop (Suc k) (take (Suc i) cs))) z  2"  
                     apply(simp add: count_append)
                      using zcsk 1(2) by(simp)
    with A have "count_list (take (Suc i) cs) z  2" by auto
    with z_occurs_once_in_cs show "False" by auto
  next
    case (2 j)
    then have 1: "Suc k+j < i" by auto
    then have f2: "j < length (drop (Suc k) (take (Suc i) cs))" using i_in_cs by simp 
    have 3: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
                                        @ (drop (Suc k) (take (Suc i) cs))! j
                                          # drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
        using f2 by(rule id_take_nth_drop)
    have "(drop (Suc k) (take (Suc i) cs))! j = (take (Suc i) cs) ! (Suc k+j)"
      apply(rule nth_drop) using i_in_cs 1 by auto
    also have " = cs ! (Suc k+j)" apply(rule nth_take) using 1 by auto
    finally have 4: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
                                        @ cs! (Suc k +j)
                                          # drop (Suc j) (drop (Suc k) (take (Suc i) cs))" 
                                         using 3 by auto
    have 5: "cs2 ! j = cs! (Suc k +j)" unfolding cs2
      apply(rule nth_drop) using i_in_cs 1 by auto
    
    from 4 5 2(2) have 6: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
                                        @ cs! k
                                          # drop (Suc j) (drop (Suc k) (take (Suc i) cs))" by auto
                                       
    from i_in_cs ki have 1: "k < length (take (Suc i) cs)" by auto 
    then have 7: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
      by(rule id_take_nth_drop)
    have 9: "(take (Suc i) cs)!k = z" unfolding zcsk apply(rule nth_take) using ki by auto
    from 6 7 have A: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
                                        @ z
                                          # drop (Suc j) (drop (Suc k) (take (Suc i) cs))" using ki 9  by auto
    
    have "count_list ((take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
                                        @ z
                                          # drop (Suc j) (drop (Suc k) (take (Suc i) cs))) z
                                             2"
                                            by(simp add: count_append)
    with A have "count_list (take (Suc i) cs) z  2" by auto
    with z_occurs_once_in_cs show "False" by auto
qed 
 

   have k_in_cs: "k < length cs" using ki i_in_cs by auto
   with cs1 have lenkk: "length cs1 = k+1" by auto
   from k_in_cs have mincsk: "min (length cs) (Suc k) = Suc k" by auto

   have "s_TS init h (((as@[x]@bs@[x])@cs1) @ cs2) (length (as@[x]@bs@[x])+k+1)
        = s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x])+k+1)"
        apply(rule s_TS_append)
          using cs1 cs2 k_in_cs by(simp)
   then have spliter: "s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))
        = s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+k+1) "
          using lenkk v cs1 apply(auto) by (simp add: add.commute add.left_commute)
       
   from cs2 have "length cs2 = length cs - (Suc k)" by auto

   have notxbeforez: "~ x < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + k + 1)"
   proof (rule ccontr, goal_cases)
    case 1 
    then have a: "x < z in s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))"
      unfolding spliter assms(1) by auto

    have 41: "x  set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
       using i_in_cs assms(4) by(simp add: s_TS_set)
    have 42: "z  set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))" 
       using i_in_cs zininit by(simp add: s_TS_set)
     
    have rewr: "s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1)) =
            s_TS init h (as@[x]@bs@[x]@cs) (length (as@[x]@bs@[x])+i)"
            using cs1 v ki  apply(simp add: mincsk) by (simp add: add.commute add.left_commute)

    have "x < z in s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1))"
      apply(rule TS_mono)
        using a apply(simp)
        using cs2 i_in_cs ki v cs1 apply(simp)  
        using z_lastocc zcsk apply(simp)
        using v assms(2) apply force
        using assms by(simp_all add: cs1 cs2)
    
    (* "contradiction to zmustbebeforex" *) 
    from zmustbebeforex this[unfolded rewr ] el_n_x zcsk 41 42 not_before_in show "False"
      unfolding s_TS_def  by fastforce
   qed
       
   have 1: "k < length cs"
                   "(j<k. cs ! j  cs ! k)"
                   "cs ! k  x" "cs ! k  set bs" 
              "~ x < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + k + 1)"
       apply(safe)
          using ki i_in_cs apply(simp)
          using z_firstocc apply(simp)
          using assms(2) ki i_in_cs apply(fastforce)
          using z_notinbs apply(simp)
          using notxbeforez by auto
          
          
                    
   show ?case apply(simp only: ex_nat_less_eq)
      apply(rule bexI[where x=k])
        using 1 zcsk apply(simp)
        using ki by simp
qed

lemma nopaid: "snd (fst (TS_step_d s q)) = []" unfolding TS_step_d_def by simp

lemma staysuntouched:
   assumes d[simp]: "distinct (fst S)"
    and x: "x  set (fst S)"
    and y: "y  set (fst S)" 
   shows "set qs  set (fst S)  x  set qs  y  set qs
         x < y in fst (config' (rTS []) S qs) =  x < y in fst S" 
proof(induct qs rule: rev_induct)
  case (snoc q qs)
  have "x < y in fst (config' (rTS []) S (qs @ [q])) =
          x < y in fst (config' (rTS []) S qs)"
          apply(simp add: config'_snoc Step_def split_def step_def rTS_def nopaid)
          apply(rule xy_relativorder_mtf2)
            using snoc by(simp_all add: x y )
  also have " = x < y in fst S"
    apply(rule snoc)
    using snoc by simp_all
  finally show ?case .
qed simp

lemma staysuntouched':
   assumes d[simp]: "distinct init"
    and x: "x  set init"
    and y: "y  set init"
    and "set qs  set init"
    and "x  set qs" and "y  set qs"
   shows "x < y in fst (config (rTS []) init qs) =  x < y in init" 
proof -
  let ?S="(init, fst (rTS []) init)"
  have "x < y in fst (config' (rTS []) ?S qs) =  x < y in fst ?S"
    apply(rule staysuntouched)
      using assms by(simp_all)
  then show ?thesis by simp
qed

lemma projEmpty: "Lxy qs S = []  x  S  x  set qs"
unfolding Lxy_def by (metis filter_empty_conv)  

lemma Lxy_index_mono:
  assumes "xS" "yS"
    and "index xs x < index xs y"
    and "index xs y < length xs"
    and "xy"
  shows "index (Lxy xs S) x < index (Lxy xs S) y"
proof -
  from assms have ij: "index xs x < index xs y"
        and xinxs: "index xs x < length xs"
        and yinxs: "index xs y < length xs" by auto  
  then have inset: "xset xs" "yset xs" using index_less_size_conv by fast+
  from xinxs obtain a as where dec1: "a @ [xs!index xs x] @ as = xs"
        and a: "a = take (index xs x) xs" and "as = drop (Suc (index xs x)) xs"
        and length_a: "length a = index xs x" and length_as: "length as = length xs - index xs x- 1"
        using id_take_nth_drop by fastforce 
  have "index xs ylength (a @ [xs!index xs x])" using length_a ij by auto
  then have "((a @ [xs!index xs x]) @ as) ! index xs y = as ! (index xs y-length (a @ [xs ! index xs x]))" using nth_append[where xs="a @ [xs!index xs x]" and ys="as"]
    by(simp)
  then have xsj: "xs ! index xs y = as ! (index xs y-index xs x-1)" using dec1 length_a by auto   
  have las: "(index xs y-index xs x-1) < length as" using length_as yinxs ij by simp
  obtain b c where dec2: "b @ [xs!index xs y] @ c = as"
            and "b = take (index xs y-index xs x-1) as" "c=drop (Suc (index xs y-index xs x-1)) as"
            and length_b: "length b = index xs y-index xs x-1" using id_take_nth_drop[OF las] xsj by force

  have xs_dec: "a @ [xs!index xs x] @ b @ [xs!index xs y] @ c = xs" using dec1 dec2 by auto 
   

  then have "Lxy xs S = Lxy (a @ [xs!index xs x] @ b @ [xs!index xs y] @ c) S"
    by(simp add: xs_dec)
  also have " = Lxy a S @ Lxy [x] S @ Lxy b S @ Lxy [y] S @ Lxy c S"
    by(simp add: Lxy_append Lxy_def assms inset)
  finally have gr: "Lxy xs S = Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S"
      using assms by(simp add: Lxy_def)

  have "y  set (take (index xs x) xs)" 
    apply(rule index_take) using assms by simp
  then have "y   set (Lxy (take (index xs x) xs) S )"
    apply(subst Lxy_set_filter) by blast
  with a have ynot: "y  set (Lxy a S)" by simp
  have "index (Lxy xs S) y =
          index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) y"
            by(simp add: gr)
  also have "  length (Lxy a S) + 1"
    using assms(5) ynot by(simp add: index_append)
  finally have 1: "index (Lxy xs S) y  length (Lxy a S) + 1" .

  have "index (Lxy xs S) x = index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) x"
    by (simp add: gr)
  also have "   length (Lxy a S)"
    apply(simp add: index_append)
    apply(subst index_less_size_conv[symmetric]) by simp
  finally have 2: "index (Lxy xs S) x  length (Lxy a S)" .

  from 1 2 show ?thesis by linarith
qed

lemma proj_Cons: 
  assumes filterd_cons: "Lxy qs S = a#as"
    and a_filter: "aS"
  obtains pre suf where "qs = pre @ [a] @ suf" and "x. x  S  x  set pre"
                  and "Lxy suf S = as"
proof -
  have "set (Lxy qs S)  set qs" using Lxy_set_filter by fast
  with filterd_cons have a_inq: "a  set qs" by simp
  then have "index qs a < length qs" by(simp)
  { fix e
    assume eS:"eS"
    assume "ea"
    have "index qs a  index qs e"
    proof (rule ccontr)
      assume "¬ index qs a  index qs e"
      then have 1: "index qs e < index qs a" by simp
      have 0: "index (Lxy qs S) a = 0" unfolding filterd_cons by simp
      have 2: "index (Lxy qs S) e < index (Lxy qs S) a"
        apply(rule Lxy_index_mono)
          by(fact)+
      from 0 2 show "False" by linarith
    qed
  } note atfront=this


  let ?lastInd="index qs a"
  have "qs = take ?lastInd qs @ qs!?lastInd # drop (Suc ?lastInd) qs"
    apply(rule id_take_nth_drop)
      using a_inq by simp
  also have " = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs"
    using a_inq by simp
  finally have split: "qs = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs" .
  
  have nothingin: "s. sS  s  set (take ?lastInd qs)"
    apply(rule index_take)
    apply(case_tac "a=s")
      apply(simp)
     by (rule atfront) simp_all
  then have "set (Lxy (take ?lastInd qs) S) = {}"
    apply(subst Lxy_set_filter) by blast
  then have emptyPre: "Lxy (take ?lastInd qs) S = []" by blast


  have "a#as = Lxy qs S"
    using filterd_cons by simp
  also have " = Lxy (take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs) S"
    using split by simp
  also have " = Lxy (take ?lastInd qs) S @ (Lxy [a] S) @ Lxy (drop (Suc ?lastInd) qs) S"
    by(simp add: Lxy_append Lxy_def)
  also have " = a#Lxy (drop (Suc ?lastInd) qs) S"
    unfolding emptyPre by(simp add: Lxy_def a_filter)
  finally have suf: "Lxy (drop (Suc ?lastInd) qs) S = as" by simp
  
  from split nothingin suf show ?thesis ..                          
qed

lemma Lxy_rev: "rev (Lxy qs S) = Lxy (rev qs) S"
apply(induct qs)
  by(simp_all add: Lxy_def)

lemma proj_Snoc: 
  assumes filterd_cons: "Lxy qs S = as@[a]"
    and a_filter: "aS"
  obtains pre suf where "qs = pre @ [a] @ suf" and "x. x  S  x  set suf"
                  and "Lxy pre S = as"
proof - 
  have "Lxy (rev qs) S = rev (Lxy qs S)" by(simp add: Lxy_rev)
  also have " = a#(rev as)" unfolding filterd_cons by simp
  finally have "Lxy (rev qs) S = a # (rev as)" .
  with a_filter
  obtain pre' suf' where 1: "rev qs = pre' @[a] @ suf'"
          and 2: "x. x  S  x  set pre'"
          and 3: "Lxy suf' S = rev as"
    using proj_Cons by metis
  have "qs = rev (rev qs)" by simp 
  also have " = rev suf' @ [a] @ rev pre'" using 1 by simp
  finally have a1: "qs = rev suf' @ [a] @ rev pre'" .

  have "Lxy (rev suf') S = rev (Lxy suf' S)" by(simp add: Lxy_rev)
  also have " = as" using 3 by simp
  finally have a3: "Lxy (rev suf') S = as" .

  have a2: "x. x  S  x  set (rev pre')" using 2 by simp

  from a1 a2 a3 show ?thesis ..
qed

lemma sndTSconfig': "snd (config' (rTS initH) (init,[]) qs) = rev qs @ []"
apply(induct qs rule: rev_induct)
  apply(simp add: rTS_def)
  by(simp add: split_def TS_step_d_def config'_snoc Step_def rTS_def)

lemma projxx: 
  fixes e a bs
  assumes axy: "a{x,y}"
  assumes ane: "ae"
  assumes exy: "e{x,y}"
  assumes add: "f{[],[e]}" 
  assumes bsaxy: "set (bs @ [a] @ f)  {x,y}"
  assumes Lxyinitxy: "Lxy init {x, y}  {[x,y],[y,x]}"
  shows "a < e in fst (configp (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
proof -
  have aexy: "{a,e}={x,y}" using exy axy ane by blast

  let ?h="snd (Partial_Cost_Model.config' (λs. [], TS_step_d)
                          (Lxy init {x, y}, []) (bs @ a # f))"
  have history: "?h = (rev f)@a#(rev bs)"
    using sndTSdet[of "length (bs@a#f)" "bs@a#f", unfolded rTS_def] by(simp) 
 
  { fix xs s
    assume sinit: "s:{[a,e],[e,a]}"
    assume "set xs  {a,e}"
    then have "fst (config' (λs. [], TS_step_d) (s, []) xs)  {[a,e], [e,a]}"
      apply (induct xs rule: rev_induct)
        using sinit apply(simp)                
       apply(subst config'_append2)
       apply(simp only: Step_def config'.simps Let_def split_def fst_conv)
       apply(rule stepxy) by simp_all  
   } note staysae=this

  have opt: "fst (config' (λs. [], TS_step_d)
                                       (Lxy init {x, y}, []) (bs @ [a] @ f))  {[a,e], [e,a]}"
    apply(rule staysae)
      using Lxyinitxy exy axy ane apply fast
      unfolding aexy by(fact bsaxy)

  have contr: " (x. 0 < (if e = x then 0 else index [a] x + 1)) = False"
  proof (rule ccontr, goal_cases)
    case 1
    then have "x. 0 < (if e = x then 0 else index [a] x + 1)" by simp
    then have "0 < (if e = e then 0 else index [a] e + 1)" by blast
    then have "0<0" by simp
    then show "False" by auto
  qed
    

  show "a < e in fst (configp (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
      apply(subst config_append)
      apply(simp add: rTS_def Step_def split_def)
      apply(subst TS_step_d_def)
      apply(simp only: history)
      using opt ane add
      apply(auto simp: step_def)
           apply(simp add: before_in_def)
          apply(simp add: before_in_def)
         apply(simp add: before_in_def contr)
        apply(simp add: mtf2_def swap_def before_in_def)
       apply(auto simp add: before_in_def contr)
       apply (metis One_nat_def add_is_1 count_list.simps(1) le_Suc_eq)
      by(simp add: mtf2_def swap_def)          
qed

lemma oneposs: 
   assumes "set xs = {x,y}"
      assumes "xy"
      assumes "distinct xs"
      assumes True: "x<y in xs"
      shows "xs = [x,y]"
proof -
  from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
  from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
        by simp_all
  then have f: "index xs x = 0  index xs y = 1" using len2 by linarith
  have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = take 1 xs @ [xs!1]" using len2 by simp
  also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = [xs!0]" by(simp)
  finally have "xs = [xs!0, xs!1]" by simp
  also have " = [xs!(index xs x), xs!index xs y]" using f by simp
  also have " = [x,y]" using assms by(simp) 
  finally show "xs = [x,y]" . 
qed

lemma twoposs: 
   assumes "set xs = {x,y}"
      assumes "xy"
      assumes "distinct xs"
      shows "xs  {[x,y], [y,x]}"
proof (cases "x<y in xs")
  case True
  from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
  from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
        by simp_all
  then have f: "index xs x = 0  index xs y = 1" using len2 by linarith
  have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = take 1 xs @ [xs!1]" using len2 by simp
  also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = [xs!0]" by(simp)
  finally have "xs = [xs!0, xs!1]" by simp
  also have " = [xs!(index xs x), xs!index xs y]" using f by simp
  also have " = [x,y]" using assms by(simp) 
  finally have "xs = [x,y]" .
  then show ?thesis by simp
next
  case False
  from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
  from False have "y<x in xs" using not_before_in assms(1,2) by fastforce
  then have "index xs y < index xs x" "index xs x < length xs" unfolding before_in_def using assms
        by simp_all
  then have f: "index xs y = 0  index xs x = 1" using len2 by linarith
  have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = take 1 xs @ [xs!1]" using len2 by simp
  also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
    apply(rule id_take_nth_drop) using len2 by simp
  also have " = [xs!0]" by(simp)
  finally have "xs = [xs!0, xs!1]" by simp
  also have " = [xs!(index xs y), xs!index xs x]" using f by simp
  also have " = [y,x]" using assms by(simp) 
  finally have "xs = [y,x]" .
  then show ?thesis by simp
qed

lemma TS_pairwise': assumes "qs  {xs. set xs  set init}"
       "(x, y)  {(x, y). x  set init  y  set init  x  y}"
       "x  y" "distinct init"
   shows "Pbefore_in x y (embed (rTS [])) qs init =
       Pbefore_in x y (embed (rTS [])) (Lxy qs {x, y}) (Lxy init {x, y})"
proof -
  from assms have xyininit: "{x, y}  set init" 
        and qsininit: "set qs  set init" by auto
  note dinit=assms(4)
  from assms have xny: "xy" by simp
  have Lxyinitxy: "Lxy init {x, y}  {[x, y], [y, x]}"
    apply(rule twoposs)
      apply(subst Lxy_set_filter) using xyininit apply fast
      using xny Lxy_distinct[OF dinit] by simp_all
                              
  have lq_s: "set (Lxy qs {x, y})  {x,y}" by (simp add: Lxy_set_filter)
 
  (* projected history *)
  let ?pH = "snd (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
  have "?pH =snd (TSdet (Lxy init {x, y}) [] (Lxy qs {x, y}) (length (Lxy qs {x, y})))"
    by(simp)
  also have " = rev (take (length (Lxy qs {x, y})) (Lxy qs {x, y})) @ []"
    apply(rule sndTSdet) by simp
  finally have pH: "?pH = rev (Lxy qs {x, y})" by simp

  let ?pQs = "(Lxy qs {x, y})"

  have A: " x < y in fst (configp (rTS []) init qs)
      =   x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
  proof(cases "?pQs" rule: rev_cases)
    case Nil
    then have xqs: "x  set qs" and yqs: "y  set qs" by(simp_all add: projEmpty) 
    have " x < y in fst (configp (rTS []) init qs)
          =  x < y in init" apply(rule staysuntouched') using assms xqs yqs by(simp_all)
    also have " = x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
      unfolding Nil apply(simp) apply(rule Lxy_mono) using xyininit dinit by(simp_all)
    finally show ?thesis .
  next
    case (snoc as a)  
    then have "aset (Lxy qs {x, y})" by (simp)
    then have axy: "a{x,y}" by(simp add: Lxy_set_filter)
    with xyininit have ainit: "aset init" by auto
    note a=snoc
    from a axy obtain pre suf  where qs: "qs = pre @ [a] @ suf"
                  and nosuf: "e. e  {x,y}  e  set suf" 
                  and pre: "Lxy pre {x,y} = as"
          using proj_Snoc by metis
    show ?thesis
    proof (cases "as" rule: rev_cases)
      case Nil  
      from pre Nil have xqs: "x  set pre" and yqs: "y  set pre" by(simp_all add: projEmpty) 
      from xqs yqs axy have "a  set pre" by blast
      then have noocc: "index (rev pre) a = length (rev pre)" by simp
      have " x < y in fst (configp (rTS []) init qs)
            =  x < y in fst (configp (rTS []) init ((pre @ [a]) @ suf))" by(simp add: qs)
      also have " = x < y in fst (configp (rTS []) init (pre @ [a]))"
        apply(subst config_append)
        apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
      also have " = x < y in fst (configp (rTS []) init pre)"
        apply(subst config_append)
        apply(simp add: rTS_def Step_def split_def)
        apply(simp only: TS_step_d_def)
        apply(simp only: sndTSconfig'[unfolded rTS_def])
        by(simp add: noocc step_def)
      also have " = x < y in init"
        apply(rule staysuntouched') using assms xqs yqs qs by(simp_all)        
      also have " = x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
        unfolding a Nil apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
          apply(rule Lxy_mono) using xyininit dinit by(simp_all)
      finally show ?thesis .
    next
      case (snoc bs b) 
      note b=this
      with a have "bset (Lxy qs {x, y})" by (simp)
      then have bxy: "b{x,y}" by(simp add: Lxy_set_filter)
      with xyininit have binit: "bset init" by auto
      from b pre have "Lxy pre {x,y} = bs @ [b]" by simp
      with bxy obtain pre2 suf2  where bs: "pre = pre2 @ [b] @ suf2"
                    and nosuf2: "e. e  {x,y}  e  set suf2" 
                    and pre2: "Lxy pre2 {x,y} = bs"
            using proj_Snoc by metis

      from bs qs have qs2: "qs = pre2 @ [b] @ suf2 @ [a] @ suf" by simp
      
      show ?thesis
      proof (cases "a=b")
        case True
        note ab=this 
 
        let ?qs ="(pre2 @ [a] @ suf2 @ [a]) @ suf"
        {
          fix e
          assume ane: "ae"
          assume exy: "e{x,y}"
          have "a < e in fst (configp (rTS []) init qs)
              = a < e in fst (configp (rTS []) init ?qs)" using True qs2 by(simp)
          also have " = a < e in fst  (configp (rTS []) init (pre2 @ [a] @ suf2 @ [a]))"
            apply(subst config_append)
            apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
              using  exy xyininit apply fast
              using nosuf axy apply(simp)
              using nosuf exy by simp
          also have ""
            apply(simp)
            apply(rule twotox[unfolded s_TS_def, simplified])
              using nosuf2 exy apply(simp)
              using assms  apply(simp_all)
              using axy xyininit  apply fast
              using exy xyininit  apply fast
              using nosuf2 axy apply(simp)
              using ane by simp
          finally have "a < e in fst (configp (rTS []) init qs)" by simp
        } note full=this 
   
        have "set (bs @ [a])  set (Lxy qs {x, y})" using a b  by auto
        also have " = {x,y}  set qs" by (rule Lxy_set_filter)
        also have "  {x,y}" by simp
        finally have bsaxy: "set (bs @ [a])  {x,y}" .

        with xny show ?thesis
        proof(cases "x=a")
          case True
          have 1: "a < y in fst (configp (rTS []) init qs)"
            apply(rule full)
              using True xny apply blast
              by simp


          have "a < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
              = a < y in fst (configp (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
              using a b ab by simp
          also have ""
            apply(rule projxx[where bs=bs and f="[]"])
              using True apply blast
              using a b True ab xny Lxyinitxy bsaxy by(simp_all) 
          finally show ?thesis using True 1 by simp
        next
          case False
          with axy have ay: "a=y" by blast
          have 1: "a < x in fst (configp (rTS []) init qs)"
            apply(rule full)
              using False xny apply blast
              by simp
          have "a < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
              = a < x in fst (configp (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
              using a b ab by simp
          also have ""
            apply(rule projxx[where bs=bs and f="[]"])
              using True axy apply blast
              using a b True ab xny Lxyinitxy ay bsaxy by(simp_all)
          finally have 2: "a < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

          have "x < y in fst (configp (rTS []) init qs) = 
             (¬ y < x in fst (configp (rTS []) init qs))"
            apply(subst not_before_in)
              using assms by(simp_all)
          also have " = False" using  1 ay by simp
          also have " = (¬ y < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
            using 2 ay by simp
          also have " = x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
            apply(subst not_before_in)
              using assms  by(simp_all add: Lxy_set_filter)
          finally show ?thesis .
        qed
      next
        case False
        note ab=this

        show ?thesis
        proof (cases "bs" rule: rev_cases)
          case Nil
          with a b have "Lxy qs {x, y} = [b,a]" by simp
          from pre2 Nil have xqs: "x  set pre2" and yqs: "y  set pre2" by(simp_all add: projEmpty) 
          from xqs yqs bxy have "b  set pre2" by blast
          then have noocc2: "index (rev pre2) b = length (rev pre2)" by simp 
          from axy nosuf2 have "a  set suf2" by blast
          with xqs yqs axy False have "a  set ((pre2 @ b # suf2))" by(auto)
          then have noocc: "index (rev (pre2 @ b # suf2) @ []) a = length (rev (pre2 @ b # suf2))" by simp
          have " x < y in fst (configp (rTS []) init qs)
                =  x < y in fst (configp (rTS []) init ((((pre2 @ [b]) @ suf2) @ [a]) @ suf))" by(simp add: qs2)
          also have " = x < y in fst (configp (rTS []) init (((pre2 @ [b]) @ suf2) @ [a]))"
            apply(subst config_append)
            apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
          also have " = x < y in fst (configp (rTS []) init ((pre2 @ [b]) @ suf2))"
            apply(subst config_append)
            apply(simp add: rTS_def Step_def split_def)
            apply(simp only: TS_step_d_def)
            apply(simp only: sndTSconfig'[unfolded rTS_def])
            apply(simp only: noocc) by (simp add: step_def)
          also have " = x < y in fst (configp (rTS []) init (pre2 @ [b]))"
            apply(subst config_append)
            apply(rule staysuntouched) using assms xqs yqs qs2 nosuf2 by(simp_all)
          also have " = x < y in fst (configp (rTS []) init (pre2))"
            apply(subst config_append)
            apply(simp add: rTS_def Step_def split_def)
            apply(simp only: TS_step_d_def)
            apply(simp only: sndTSconfig'[unfolded rTS_def])
            by(simp add: noocc2 step_def)
          also have " = x < y in init"
            apply(rule staysuntouched') using assms xqs yqs qs2 by(simp_all)        
          also have " = x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
            unfolding a b Nil
            using False
            apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def) 
              apply(rule Lxy_mono) using xyininit dinit by(simp_all)
          finally show ?thesis . 
        next
          case (snoc cs c)   
          note c=this
          with a b have "cset (Lxy qs {x, y})" by (simp)
          then have cxy: "c{x,y}" by(simp add: Lxy_set_filter)
          from c pre2 have "Lxy pre2 {x,y} = cs @ [c]" by simp
          with cxy obtain pre3 suf3  where cs: "pre2 = pre3 @ [c] @ suf3"
                        and nosuf3: "e. e  {x,y}  e  set suf3" 
                        and pre3: "Lxy pre3 {x,y} = cs"
                using proj_Snoc by metis    

          let ?qs=" pre3 @ [c] @ suf3 @ [b] @ suf2 @ [a] @ suf"
          from bs cs qs have qs2: "qs = ?qs" by simp
                   
          show ?thesis
          proof(cases "c=a")
            case True (* aba *)
            note ca=this
 
            have "a < b in fst (configp (rTS []) init qs)
                = a < b in fst (configp (rTS []) init ((pre3 @ a # (suf3 @ [b] @ suf2) @ [a]) @ suf))"
                  using qs2 True by simp
            also have " = a < b in fst (configp (rTS []) init (pre3 @ a # (suf3 @ [b] @ suf2) @ [a]))"
              apply(subst config_append)
              apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
                using bxy xyininit apply(fast)
                using nosuf axy bxy by(simp_all)
            also have "..."
              apply(rule twotox[unfolded s_TS_def, simplified])
                using nosuf2 nosuf3 bxy apply(simp add: count_append)
                using assms apply(simp_all)
                using axy xyininit apply(fast)
                using bxy xyininit apply(fast)
                using ab nosuf2 nosuf3 axy apply(simp)
                using ab by simp
            finally have full: "a < b in fst (configp (rTS []) init qs)" by simp
  

            have "set (cs @ [a] @ [b])  set (Lxy qs {x, y})" using a b c  by auto
            also have " = {x,y}  set qs" by (rule Lxy_set_filter)
            also have "  {x,y}" by simp
            finally have csabxy: "set (cs @ [a] @ [b])  {x,y}" .

            with xny show ?thesis
            proof(cases "x=a")
              case True
              with xny ab bxy have bisy: "b=y" by blast
              have 1: "x < y in fst (configp (rTS []) init qs)"
                using full True bisy by simp

              have "a < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
                  = a < y in fst (configp (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
                  using a b c ca ab by simp
              also have ""
                apply(rule projxx)
                  using True apply blast
                  using a b True ab xny Lxyinitxy csabxy by(simp_all) 
              finally show ?thesis using 1 True by simp
            next
              case False
              with axy have ay: "a=y" by blast
              with xny ab bxy have bisx: "b=x" by blast
              have 1: "y < x in fst (configp (rTS []) init qs)"
                using full ay bisx by simp

              have "a < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
                  = a < x in fst (configp (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
                  using a b c ca ab by simp
              also have ""
                apply(rule projxx) 
                  using a b True ab xny Lxyinitxy csabxy False by(simp_all) 
              finally have 2: "a < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .
    
              have "x < y in fst (configp (rTS []) init qs) = 
                 (¬ y < x in fst (configp (rTS []) init qs))"
                apply(subst not_before_in)
                  using assms by(simp_all)
              also have " = False" using  1 ay by simp
              also have " = (¬ y < x in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
                using 2 ay by simp
              also have " = x < y in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
                apply(subst not_before_in)
                  using assms  by(simp_all add: Lxy_set_filter)
              finally show ?thesis .
            qed
          next
            case False  (* bba *)
            then have cb: "c=b" using bxy cxy axy ab by blast
            
            let ?cs = "suf2 @ [a] @ suf"
            let ?i = "index ?cs a"


            have aed: "(j<index (suf2 @ a # suf) a. (suf2 @ a # suf) ! j  a)"
              by (metis add.right_neutral axy index_Cons index_append nosuf2 nth_append nth_mem)
 
            have "?i < length ?cs      
               (j<?i. ?cs ! j  ?cs ! ?i)  ?cs ! ?i  b
                 ?cs ! ?i  set suf3
                 b < ?cs ! ?i in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
              apply(rule casexxy) 
                     using cb qs2 apply(simp)
                    using bxy ab nosuf2 nosuf apply(simp)
                   using bs qs qsininit apply(simp)
                  using bxy xyininit apply(blast)
                 apply(fact)
                using nosuf3 bxy apply(simp)
              using cs bs qs qsininit by(simp_all)
                
            then have inner: "b < a in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
              using ab nosuf3 axy bxy aed
              by(simp) 
            let ?n = "(length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
            let ?inner="(configp (rTS []) init (take (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1) ?qs))"

            have "b < a in fst (configp (rTS []) init qs)
              = b < a in fst (configp (rTS []) init (take ?n ?qs @ drop ?n ?qs))" using qs2 by simp
            also have " = b < a in fst (config' (rTS []) ?inner suf)" apply(simp only: config_append drop_append) 
              using nosuf2 axy by(simp add: index_append config_append)
            also have " = b < a in fst ?inner" 
              apply(rule staysuntouched) using assms bxy xyininit  qs nosuf apply(simp_all)
              using bxy xyininit apply(blast)
              using axy xyininit by (blast)
            also have " = True" using inner by(simp add: s_TS_def qs2)
            finally have full: "b < a in fst (configp (rTS []) init qs)" by simp
               
            have "set (cs @ [b] @ [])  set (Lxy qs {x, y})" using a b c  by auto
            also have " = {x,y}  set qs" by (rule Lxy_set_filter)
            also have "  {x,y}" by simp
            finally have csbxy: "set (cs @ [b] @ [])  {x,y}" .
 
            have "set (Lxy init {x, y}) = {x,y}  set init"
              by(rule Lxy_set_filter)
            also have " = {x,y}" using xyininit by fast
            also have " = {b,a}" using axy bxy ab by fast
            finally have r: "set (Lxy init {x, y}) = {b, a}" .

            let ?confbef="(configp (rTS []) (Lxy init {x, y}) ((cs @ [b] @ []) @ [b]))"
            have f1: "b < a in fst ?confbef"
              apply(rule projxx)
                using bxy ab axy a b c csbxy Lxyinitxy by(simp_all)
            have 1: "fst ?confbef = [b,a]" 
              apply(rule oneposs)
                using ab axy bxy xyininit Lxy_distinct[OF dinit] f1 r by(simp_all)
            have 2: "snd (Partial_Cost_Model.config'
                           (λs. [], TS_step_d)
                           (Lxy init {x, y}, [])
                           (cs @ [b, b])) = [b,b]@(rev cs)" 
              using sndTSdet[of "length (cs @ [b, b])" "(cs @ [b, b])", unfolded rTS_def] by(simp) 
            have "b < a in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
              = b < a in fst (configp (rTS []) (Lxy init {x, y}) (((cs @ [b] @ []) @ [b])@[a]))"
              using a b c cb by(simp)
            also have ""
              apply(subst config_append)
              using 1 2 ab apply(simp add: step_def Step_def split_def rTS_def TS_step_d_def)
                by(simp add: before_in_def) 
            finally have projected: "b < a in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .


            have 1: "{x,y} = {a,b}" using ab axy bxy by fast
            with xny show ?thesis
            proof(cases "x=a")
              case True
              with 1 xny have y: "y=b" by fast
              have "a < b in fst (configp (rTS []) init qs) = 
                 (¬ b < a in fst (configp (rTS []) init qs))"
                apply(subst not_before_in)
                  using binit ainit ab by(simp_all)
              also have " = False" using  full by simp
              also have " = (¬ b < a in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
                using projected by simp
              also have " = a < b in fst (configp (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
                apply(subst not_before_in)
                  using binit ainit ab axy bxy  by(simp_all add: Lxy_set_filter)
              finally show ?thesis using True y by simp
            next
              case False
              with 1 xny have y: "y=a" "x=b" by fast+
              with full projected show ?thesis by fast
            qed
          qed (* end of (c=a) *)
        qed (* end of snoc cs c *)
      qed (* end of (a=b) *)
    qed (* end snoc bs b *)
  qed (* end snoc as a *)

        


  show ?thesis unfolding Pbefore_in_def
    apply(subst config_embed)
    apply(subst config_embed)
      apply(simp) by (rule A) 
qed

theorem TS_pairwise: "pairwise (embed (rTS []))"
apply(rule pairwise_property_lemma)
  apply(rule TS_pairwise') by (simp_all add: rTS_def TS_step_d_def)


subsection "TS is 2-compet"


lemma TS_compet':   "pairwise (embed (rTS []))  
      s0{init::(nat list). distinct init  init[]}. b0. qs{x. set x  set s0}. Tp_on_rand (embed (rTS [])) s0 qs  (2::real) *  Tp_opt s0 qs + b"
unfolding rTS_def 
proof (rule factoringlemma_withconstant, goal_cases)
    case 5
    show ?case
    proof (safe, goal_cases)
      case (1 init)
      note out=this
      show ?case
        apply(rule exI[where x=2])
          apply(simp)
          proof (safe, goal_cases)
            case (1 qs a b)
            then have a: "ab" by simp
            have twist: "{a,b}={b, a}" by auto
            have b1: "set (Lxy qs {a, b})  {a, b}" unfolding Lxy_def by auto
            with this[unfolded twist] have b2: "set (Lxy qs {b, a})  {b, a}" by(auto)
        
            have "set (Lxy init {a, b}) = {a,b}  (set init)" apply(induct init)
                unfolding Lxy_def by(auto)
            with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
            have "finite {a,b}" by auto
            from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
            have C: "length (Lxy init {a, b}) = 2"
              using distinct_card[OF B, unfolded A] using a by auto
        
            have "{xs. set xs = {a,b}  distinct xs  length xs =(2::nat)} 
                    = { [a,b], [b,a] }"
                  apply(auto simp: a a[symmetric])
                  proof (goal_cases)
                    case (1 xs)
                    from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
                    with 1(4) have "length xs' = 1" by auto
                    then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
                    from r s have t: "[x,y] = xs" by auto
                    moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
                    moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
                    ultimately show ?case by auto
                  qed
        
            with A B C have pos: "(Lxy init {a, b}) = [a,b]
                   (Lxy init {a, b}) = [b,a]" by auto
            
            { fix a::nat
              fix b::nat
              fix qs
              assume as: "a  b" "set qs  {a, b}"
              have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b]  (λis. return_pmf ([a,b], is))) qs
                    = Tp_on (rTS []) [a, b] qs" by (rule  T_on_embed[symmetric])
              also from as have "  2 * Tp_opt [a, b] qs + 2" using TS_OPT2' by fastforce 
              finally have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b]  (λis. return_pmf ([a,b], is))) qs
                     2 * Tp_opt [a, b] qs + 2"  .
            } note ye=this

            show ?case
              apply(cases "(Lxy init {a, b}) = [a,b]")  
                using ye[OF a b1, unfolded rTS_def] apply(simp)
                using pos ye[OF a[symmetric] b2, unfolded rTS_def] by(simp add: twist) 
          qed
    qed
next
  case 6
  show ?case unfolding TS_step_d_def by (simp add: split_def TS_step_d_def)
next
  case (7 init qs x) 
  then show ?case
    apply(induct x) 
      by (simp_all add: rTS_def split_def take_Suc_conv_app_nth config'_rand_snoc ) 
next
  case 4 then show ?case by simp
qed (simp_all)
 

lemma TS_compet: "compet_rand (embed (rTS [])) 2 {init. distinct init  init  []}"
unfolding compet_rand_def static_def
using TS_compet'[OF TS_pairwise] by simp
 
end

Theory BIT_pairwise

section "BIT is pairwise"

theory BIT_pairwise
imports List_Factoring BIT
begin

lemma L_nths: "S  {..<length init}
   map_pmf (λl. nths l S) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (nths init S)))"
proof(induct init arbitrary: S)
  case (Cons a as)
  then have passt: "{j. Suc j  S}  {..<length as}" by auto

  have " map_pmf (λl. nths l S) (Prob_Theory.bv (length (a # as))) = 
    Prob_Theory.bv (length as) 
    (λx. bernoulli_pmf (1 / 2) 
          (λxa. return_pmf
                  ((if 0  S then [xa] else []) @ nths x {j. Suc j  S})))"
      by(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf nths_Cons) 
  also have " = (bernoulli_pmf (1 / 2))  
          (λxa. (Prob_Theory.bv (length as) 
    (λx. return_pmf ((if 0  S then [xa] else []) @ nths x {j. Suc j  S}))))"
        by(rule bind_commute_pmf)
   also have " = (bernoulli_pmf (1 / 2))  
          (λxa. (map_pmf (λx. (nths x {j. Suc j  S})) (Prob_Theory.bv (length as)))
                (λxs. return_pmf ((if 0  S then [xa] else []) @ xs)))"
      by(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def)
   also have " = (bernoulli_pmf (1 / 2))  
          (λxa. Prob_Theory.bv (length (nths as {j. Suc j  S}))
                (λxs. return_pmf ((if 0  S then [xa] else []) @ xs)))"
        using Cons(1)[OF passt] by auto
   also have " = Prob_Theory.bv (length (nths (a # as) S))"
      apply(auto simp add: nths_Cons bind_return_pmf')
      by(rule bind_commute_pmf)
   finally show ?case .
qed (simp)

lemma L_nths_Lxy:
  assumes "xset init" "yset init" "xy" "distinct init" 
  shows "map_pmf (λl. nths l {index init x,index init y}) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (Lxy init {x,y})))"
proof -
  from assms(4) have setinit: "(index init) ` set init = {0..<length init}" 
  proof(induct init)
    case (Cons a as)
    with Cons have iH: "index as ` set as = {0..<length as}" by auto
    from Cons have 1:"(set as  {x. (a  x)}) = set as" by fastforce
    have 2: "(λa. Suc (index as a)) ` set as =
            (λa. Suc a) ` ((index as) ` set as )" by auto
    show ?case
    apply(simp add: 1 2 iH) by auto
  qed simp

  have xy_le: "index init x<length init" "index init y<length init" using assms by auto
  have "map_pmf (λl. nths l {index init x,index init y}) (Prob_Theory.bv (length init))
      = (Prob_Theory.bv (length (nths init {index init x,index init y})))"
        apply(rule L_nths)
        using assms(1,2) by auto
  moreover have "length (Lxy init {x,y}) = length (nths init {index init x,index init y})"
  proof -
    have "set (Lxy init {x,y}) = {x,y}" 
      using assms(1,2) by(simp add: Lxy_set_filter)
    moreover have "card {x,y} = 2" using assms(3) by auto
    moreover have "distinct (Lxy init {x,y})" using assms(4) by(simp add: Lxy_distinct)
    ultimately have 1: "length (Lxy init {x,y}) = 2" by(simp add: distinct_card[symmetric])
    have "set (nths init {index init x,index init y}) = {(init ! i) | i.  i < length init  i  {index init x,index init y}}" 
      using assms(1,2) by(simp add: set_nths)
    moreover have "card {(init ! i) | i.  i < length init  i  {index init x,index init y}} = 2"
    proof -
      have 1: "{(init ! i) | i.  i < length init  i  {index init x,index init y}} = {init ! index init x, init ! index init y}" using xy_le by blast
      also have " = {x,y}" using nth_index assms(1,2) by auto 
      finally show ?thesis using assms(3) by auto
    qed
    moreover have "distinct (nths init {index init x,index init y})" using assms(4) by(simp)
    ultimately have 2: "length (nths init {index init x,index init y}) = 2" by(simp add: distinct_card[symmetric])
    show ?thesis using 1 2 by simp
  qed
  ultimately show ?thesis by simp
qed
  
lemma nths_map: "map f (nths xs S) = nths (map f xs) S"
apply(induct xs arbitrary: S) by(simp_all  add: nths_Cons)

lemma nths_empty: "(iS. ilength xs)  nths xs S = []"
proof -
  assume "(iS. ilength xs)"
  then have "set (nths xs S) = {}" apply(simp add: set_nths) by force
  then show "nths xs S = []" by simp
qed


lemma nths_project': "i < length xs  j < length xs  i<j
    nths xs {i,j} = [xs!i, xs!j]"
proof -
  assume il: "i < length xs" and jl: "j < length xs" and ij: "i<j"

  from il obtain a as where dec1: "a @ [xs!i] @ as = xs" 
           and "a = take i xs" "as=drop (Suc i) xs" 
           and length_a: "length a = i" and length_as: "length as = length xs - i - 1"using id_take_nth_drop by fastforce
  have "jlength (a @ [xs!i])" using length_a ij by auto
  then have "((a @ [xs!i]) @ as) ! j = as ! (j-length (a @ [xs ! i]))" using nth_append[where xs="a @ [xs!i]" and ys="as"]
    by(simp)
  then have xsj: "xs ! j = as ! (j-i-1)" using dec1 length_a by auto   
  have las: "(j-i-1) < length as" using length_as jl ij by simp
  obtain b c where dec2: "b @ [xs!j] @ c = as"
            and "b = take (j-i-1) as" "c=drop (Suc (j-i-1)) as"
            and length_b: "length b = j-i-1" using id_take_nth_drop[OF las] xsj by force
  have xs_dec: "a @ [xs!i] @ b @ [xs!j] @ c = xs" using dec1 dec2 by auto 
         
  have s2: "{k. (k + i  {i, j})} = {0,j-i}"  using ij by force
  have s3: "{k. (k  + length [xs ! i]  {0, j-i})} = {j-i-1}"  using ij by force
  have s4: "{k. (k  + length b  {j-i-1})} = {0}"  using length_b by force
  have s5: "{k. (k  + length [xs!j]  {0})} = {}" by force
  have l1: "nths a {i,j} = []"
    apply(rule nths_empty) using length_a ij by fastforce
  have l2: "nths b {j - Suc i} = []"
    apply(rule nths_empty) using length_b ij by fastforce
  have "nths ( a @ [xs!i] @ b @ [xs!j] @ c) {i,j} = [xs!i, xs!j]"
      apply(simp only: nths_append length_a s2 s3 s4 s5)
      by(simp add: l1 l2)
  then show "nths xs {i,j} = [xs!i, xs!j]" unfolding xs_dec .
qed

lemma nths_project:
  assumes  "i < length xs" "j < length xs" "i<j"
   shows "nths xs {i,j} ! 0 = xs ! i  nths xs {i,j} ! 1 = xs ! j"
proof -
  from assms have "nths xs {i,j} = [xs!i, xs!j]" by(rule nths_project')
  then show ?thesis by simp
qed

lemma BIT_pairwise':
  assumes "set qs  set init"    
    "(x,y) {(x,y). x  set init  yset init  xy}"
   and  xny:"x  y" and dinit: "distinct init"
  shows "Pbefore_in x y BIT qs init = Pbefore_in x y BIT (Lxy qs {x,y}) (Lxy init {x,y})"                    
proof -
  from assms have xyininit: "{x, y}  set init" 
        and qsininit: "set qs  set init" by auto 

  have xyininit': "{y,x}  set init" using xyininit by auto
 
  have a: "x  set init" "yset init" using assms by auto 

    { fix n
    have strong: "set qs  set init 
      map_pmf (λ(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs) =
      config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y}) " (is "?inv  ?L qs = ?R qs")
    proof (induct qs rule: rev_induct)
      case Nil 

      have " map_pmf (λ(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init [])
          =  map_pmf (λw. (Lxy init {x,y}, (w, Lxy init {x,y}))) (map_pmf (λl. nths l {index init x,index init y}) (Prob_Theory.bv (length init)))"
              by(simp add: bind_return_pmf map_pmf_def bind_assoc_pmf split_def BIT_init_def)
      also have " = map_pmf (λw. (Lxy init {x,y}, (w, Lxy init {x,y}))) (Prob_Theory.bv (length (Lxy init {x, y})))" 
          using L_nths_Lxy[OF a xny dinit] by simp
      also have " = config_rand BIT  (Lxy init {x, y}) (Lxy [] {x, y})"
          by(simp add: BIT_init_def bind_return_pmf bind_assoc_pmf map_pmf_def)
      finally show ?case . 
    next
      case (snoc q qs)
      then have qininit: "q   set init" 
            and qsininit: "set qs  set init" using qsininit by auto

      from  snoc(1)[OF qsininit] have iH: "?L qs = ?R qs" by (simp add: split_def)

      show ?case 
      proof (cases "q  {x,y}")
        case True
        note whatisq=this
 
        have "?L (qs@[q]) =
         map_pmf (λ(l,(w,i)). (Lxy l {x,y},(nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs 
              (λs. BIT_step s q  (λ(a, nis). return_pmf (step (fst s) q a, nis))))"
             by(simp add: split_def config'_rand_snoc) 
        also have " =
        map_pmf (λ(l,(w,i)). (Lxy l {x,y}, (nths w {index init x,index init y},Lxy init {x,y}))) (config_rand BIT init qs) 
        (λs.
            BIT_step s q 
            (λ(a, nis). return_pmf (step (fst s) q a, nis))) "
           apply(simp add: map_pmf_def split_def bind_return_pmf bind_assoc_pmf)
           apply(simp add: BIT_step_def bind_return_pmf)
        proof (rule bind_pmf_cong, goal_cases)
          case (2 z)
          let ?s = "fst z"
          let ?b = "fst (snd z)"

          from 2 have z: "set (?s) = set init" using config_rand_set[of BIT, simplified]  by metis
          with True have qLxy: "q  set (Lxy (?s) {x, y})" using   xyininit by (simp add: Lxy_set_filter)
          from 2 have dz: "distinct (?s)" using dinit config_rand_distinct[of BIT, simplified] by metis
          then have dLxy: "distinct (Lxy (?s) {x, y})" using Lxy_distinct by auto

          from 2 have [simp]: "snd (snd z) = init" using config_n_init3[simplified]   by metis

          from 2 have [simp]: "length (fst (snd z)) = length init" using config_n_fst_init_length2[simplified] by metis 

          have indexinbounds: "index init x < length init" "index init y < length init"  using a by auto
          from a xny have indnot: "index init x  index init y" by auto



          have f1: "index init x < length (fst (snd z))" using xyininit by auto
          have f2: "index init y < length (fst (snd z))" using xyininit by auto
          have 3: "index init x  index init y" using xny xyininit by auto

          
          from dinit have dfil: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)
          have Lxy_set: "set (Lxy init {x, y}) = {x,y}" apply(simp add: Lxy_set_filter) using xyininit by fast
          then have xLxy: "xset (Lxy init {x, y})" by auto
          have Lxy_length: "length (Lxy init {x, y}) = 2" using dfil Lxy_set xny distinct_card by fastforce 
          have 31:  "index (Lxy init {x, y}) x < 2" 
              and  32:  "index (Lxy init {x, y}) y < 2" using Lxy_set xyininit Lxy_length by auto
          have 33: "index (Lxy init {x, y}) x  index (Lxy init {x,y}) y"
            using xny xLxy by auto
 
          have a1: "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})" (is "?A=?B")
          proof (simp only: list_eq_iff_nth_eq, goal_cases)
            case 1

            {assume ass: "index init x < index init y"
              then have "index (Lxy init {x,y}) x < index (Lxy init {x,y}) y"
                using Lxy_mono[OF xyininit dinit] before_in_def a(2) by force  
              with 31 32 have ix: "index (Lxy init {x,y}) x = 0"
                      and iy: "index (Lxy init {x,y}) y = 1" by auto


             have g1: "(nths (fst (snd z)) {index init x,index init y}) 
                        = [(fst (snd z)) ! index init x, (fst (snd z)) ! index init y]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact


            have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                  = [flip (index init (q)) (fst (snd z))!index init x,
                        flip (index init (q)) (fst (snd z))!index init y]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact
            also have " = flip (index (Lxy init {x,y}) (q)) [(fst (snd z)) ! index init x, (fst (snd z)) ! index init y]" 
              apply(cases "q=x")
                apply(simp add: ix) using flip_other[OF f2 f1 3] flip_itself[OF f1] apply(simp)
                using whatisq apply(simp add: iy) using flip_other[OF f1 f2 3[symmetric]] flip_itself[OF f2] by(simp)
            finally have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})" 
                    by(simp add: g1)
                          
            }note cas1=this
            have man: "{x,y} = {y,x}" by auto
            {assume "~ index init x < index init y"
              then have ass: "index init y < index init x" using 3 by auto
              then have "index (Lxy init {x,y}) y < index (Lxy init {x,y}) x"
                using Lxy_mono[OF xyininit' dinit] xyininit a(1) man by(simp add: before_in_def)
              with 31 32 have ix: "index (Lxy init {x,y}) x = 1"
                      and iy: "index (Lxy init {x,y}) y = 0" by auto


             have g1: "(nths (fst (snd z)) {index init y,index init x}) 
                        = [(fst (snd z)) ! index init y, (fst (snd z)) ! index init x]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact

            have man2: "{index init x,index init y} = {index init y,index init x}" by auto
            have "nths (flip (index init (q)) (fst (snd z))) {index init y,index init x}
                  = [flip (index init (q)) (fst (snd z))!index init y,
                        flip (index init (q)) (fst (snd z))!index init x]"
                        apply(rule nths_project')
                          using xyininit apply(simp)
                          using xyininit apply(simp)
                          by fact
            also have " = flip (index (Lxy init {x,y}) (q)) [(fst (snd z)) ! index init y, (fst (snd z)) ! index init x]" 
              apply(cases "q=x")
                apply(simp add: ix) using flip_other[OF f2 f1 3] flip_itself[OF f1] apply(simp)
                using whatisq apply(simp add: iy) using flip_other[OF f1 f2 3[symmetric]] flip_itself[OF f2] by(simp)
            finally have "nths (flip (index init (q)) (fst (snd z))) {index init y,index init x}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init y,index init x})" 
                    by(simp add: g1)
            then have "nths (flip (index init (q)) (fst (snd z))) {index init x,index init y}
                    = flip (index (Lxy init {x,y}) (q)) (nths (fst (snd z)) {index init x,index init y})" 
                    using man2 by auto                          
            } note cas2=this

            from cas1 cas2 3 show ?case by metis 
          qed

          have a: "nths (fst (snd z)) {index init x, index init y} ! (index (Lxy init {x,y}) (q))
                    = fst (snd z) ! (index init (q))"
          proof -
            from 31 32  33have ca: "(index (Lxy init {x,y}) x = 0  index (Lxy init {x,y}) y = 1)
                     (index (Lxy init {x,y}) x = 1  index (Lxy init {x,y}) y = 0)" by force
            show ?thesis
            proof (cases "index (Lxy init {x,y}) x = 0")
              case True

              from True ca have y1: "index (Lxy init {x,y}) y = 1" by auto
              with True have "index (Lxy init {x,y}) x < index (Lxy init {x,y}) y" by auto
              then have xy: "index init x < index init y" using dinit dfil Lxy_mono 
                      using "32" before_in_def Lxy_length xyininit by fastforce 
                  

              have 4: " {index init y, index init x} =  {index init x, index init y}" by auto

              have "nths (fst (snd z)) {index init x, index init y} ! index (Lxy init {x,y}) x = (fst (snd z)) ! index init x"
                       "nths (fst (snd z)) {index init x, index init y} ! index (Lxy init {x,y}) y = (fst (snd z)) ! index init y"
                       unfolding True y1 
                          by (simp_all only: nths_project[OF f1 f2 xy])  
              with whatisq show ?thesis by auto
           next
              case False
              with ca have x1: "index (Lxy init {x,y}) x = 1" by auto
              from dinit have dfil: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)

              from x1 ca have y1: "index (Lxy init {x,y}) y = 0" by auto
              with x1 have "index (Lxy init {x,y}) y < index (Lxy init {x,y}) x" by auto
              then have xy: "index init y < index init x" using dinit dfil Lxy_mono 
                      using "32" before_in_def Lxy_length xyininit by (metis a(2) indnot linorder_neqE_nat not_less0 y1) 
                  

              have 4: " {index init y, index init x} =  {index init x, index init y}" by auto
 
              have "nths (?b) {index init x, index init y} ! index (Lxy init {x,y}) x = (?b) ! index init x"
                       "nths (?b) {index init x, index init y} ! index (Lxy init {x,y}) y = (?b) ! index init y"
                       unfolding x1 y1 
                        using 4 nths_project[OF  f2 f1 xy]
                          by simp_all  
              with whatisq show ?thesis by auto
           qed
         qed


          have b: "Lxy (mtf2 (length ?s) (q) ?s) {x, y} 
                =  mtf2 (length (Lxy ?s {x, y})) (q) (Lxy ?s {x, y})" (is "?A = ?B")
          proof -
                have sA: "set ?A = {x,y}" using z xyininit by(simp add: Lxy_set_filter)
                then have xlxymA: "x  set ?A"
                      and ylxymA: "y  set ?A" by auto
                have dA: "distinct ?A" apply(rule Lxy_distinct) by(simp add: dz)
                have lA: "length ?A = 2" using xny sA dA distinct_card by fastforce 
                from lA ylxymA have yindA: "index ?A y < 2" by auto
                from lA xlxymA have xindA: "index ?A x < 2" by auto
                have geA: "{x,y}  set (mtf2 (length ?s) (q) ?s)" using xyininit z by auto
                have geA': "{y,x}  set (mtf2 (length ?s) (q) (?s))" using xyininit z by auto
                have man: "{y,x} = {x,y}" by auto

                have sB: "set ?B = {x,y}" using z xyininit by(simp add: Lxy_set_filter)
                then have xlxymB: "x  set ?B"
                  and ylxymB: "y  set ?B" by auto
                have dB: "distinct ?B" apply(simp) apply(rule Lxy_distinct) by(simp add: dz)
                have lB: "length ?B = 2" using xny sB dB distinct_card by fastforce 
                from lB ylxymB have yindB: "index ?B y < 2" by auto
                from lB xlxymB have xindB: "index ?B x < 2" by auto
                
                show ?thesis
                proof (cases "q = x")                
                  case True
                  then have xby: "x < y in (mtf2 (length (?s)) (q) (?s))"
                    apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: dz)
                  then have "x < y in ?A" using Lxy_mono[OF geA] dz by(auto)
                  then have "index ?A x < index ?A y" unfolding before_in_def by auto
                  then have in1: "index ?A x = 0"
                          and in2: "index ?A y = 1"  using yindA by auto
                  have "?A = [?A!0,?A!1]" 
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(auto simp: lA) apply(case_tac i) by(auto)
                  also have " = [?A!index ?A x, ?A!index ?A y]" by(simp only: in1 in2)
                  also have " = [x,y]" using xlxymA ylxymA  by simp    
                  finally have end1: "?A  = [x,y]" .
                  
                  have "x < y in ?B"
                    using True apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: Lxy_distinct dz Lxy_set_filter)
                  then have "index ?B x < index ?B y"
                            unfolding before_in_def by auto
                  then have in1: "index ?B x = 0"
                          and in2: "index ?B y = 1"
                            using yindB by auto
  
                  have "?B = [?B!0, ?B!1]" 
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(simp only: lB)
                            apply(auto) apply(case_tac i) by(auto)
                  also have " = [?B!index ?B x,  ?B!index ?B y]"
                                 by(simp only: in1 in2)
                  also have " = [x,y]" using xlxymB ylxymB  by simp    
                  finally have end2: "?B = [x,y]" .
  
                  then show "?A = ?B " using end1 end2 by simp
              next             
                  case False
                  with whatisq have qsy: "q=y" by simp
                  then have xby: "y < x in (mtf2 (length (?s)) (q) (?s))"
                    apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: dz)
                  then have "y < x in ?A" using Lxy_mono[OF geA'] man dz by auto
                  then have "index ?A y < index ?A x" unfolding before_in_def by auto
                  then have in1: "index ?A y = 0"
                          and in2: "index ?A x = 1"  using xindA by auto
                  have "?A = [?A!0,?A!1]" 
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(auto simp: lA) apply(case_tac i) by(auto)
                  also have " = [?A!index ?A y, ?A!index ?A x]" by(simp only: in1 in2)
                  also have " = [y,x]" using xlxymA ylxymA  by simp    
                  finally have end1: "?A  = [y,x]" .
                  
                  have "y < x in ?B"
                    using qsy apply(simp)
                          apply(rule mtf2_moves_to_front''[simplified])
                            using z xyininit xny by(simp_all add: Lxy_distinct dz Lxy_set_filter)
                  then have "index ?B y < index ?B x"
                            unfolding before_in_def by auto
                  then have in1: "index ?B y = 0"
                          and in2: "index ?B x = 1"
                            using xindB by auto
  
                  have "?B = [?B!0, ?B!1]" 
                          apply(simp only: list_eq_iff_nth_eq)
                            apply(simp only: lB)
                            apply(auto) apply(case_tac i) by(auto)
                  also have " = [?B!index ?B y,  ?B!index ?B x]"
                                 by(simp only: in1 in2)
                  also have " = [y,x]" using xlxymB ylxymB  by(simp )    
                  finally have end2: "?B = [y,x]" .
  
                  then show "?A = ?B " using end1 end2 by simp
              qed  
           qed 
          
          have a2: " Lxy (step (?s) (q) (if ?b ! (index init (q)) then 0 else length (?s), [])) {x, y}
              = step (Lxy (?s) {x, y}) (q) (if nths (?b) {index init x, index init y} ! (index (Lxy init {x,y}) (q)) 
                              then 0 
                              else length (Lxy (?s) {x, y}), [])"
               apply(auto simp add: a step_def) by(simp add: b)
 

           show ?case using a1 a2 by(simp)
        qed simp 
        also have " = ?R (qs@[q])"
          using True apply(simp add: Lxy_snoc take_Suc_conv_app_nth config'_rand_snoc)  
          using iH by(simp add: split_def ) 
        finally show ?thesis .
      next
        case False
        then have qnx: "(q)  x" and qny: "(q)  y" by auto

        let ?proj="(λa. (Lxy (fst a) {x, y}, (nths (fst (snd a)) {index init x, index init y}, Lxy init {x, y})))"
             
        have "map_pmf ?proj (config_rand BIT init (qs@[q]))
             = map_pmf ?proj (config_rand (BIT_init, BIT_step) init qs
                 (λp. BIT_step p (q)  (λpa. return_pmf (step (fst p) (q) (fst pa), snd pa)))) "
               by (simp add: split_def take_Suc_conv_app_nth config'_rand_snoc)
        also have " = map_pmf ?proj (config_rand (BIT_init, BIT_step) init qs)" 
            apply(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf BIT_step_def)
            proof (rule bind_pmf_cong, goal_cases)
              case (2 z)
              let ?s = "fst z"
              let ?m = "snd (snd z)"
              let ?b = "fst (snd z)"

              from 2 have sf_init: "?m = init" using config_n_init3 by auto

              from 2 have ff_len: "length (?b) = length init" using config_n_fst_init_length2 by auto
              
              have ff_ix: "index init x < length (?b)" unfolding ff_len using a(1) by auto
              have ff_iy: "index init y < length (?b)" unfolding ff_len using a(2) by auto
              have ff_q: "index init (q) < length (?b)" unfolding ff_len using qininit by auto
              have iq_ix: "index init (q)  index init x" using a(1) qnx by auto
              have iq_iy: "index init (q)  index init y" using a(2) qny by auto
              have ix_iy: "index init x  index init y" using a(2) xny by auto

              from 2 have s_set[simp]: "set (?s) = set init" using config_rand_set by force
              have s_xin: "xset (?s)" using a(1) by simp
              have s_yin: "yset (?s)" using a(2) by simp
              from 2 have s_dist: "distinct (?s)" using config_rand_distinct dinit by force
              have s_qin: "q  set (?s)" using qininit by simp


              have fstfst: "nths (flip (index ?m (q)) (?b))
              {index init x, index init y}
                  = nths (?b) {index init x, index init y}" (is "nths ?A ?I = nths ?B ?I")
              proof (cases "index init x < index init y")
                case True
                have "nths ?A ?I = [?A!index init x, ?A!index init y]"
                      apply(rule nths_project')
                        by(simp_all add: ff_ix ff_iy True)
                also have " = [?B!index init x, ?B!index init y]"
                  unfolding sf_init using flip_other ff_ix ff_iy ff_q iq_ix iq_iy by auto
                also have " = nths ?B ?I"
                      apply(rule nths_project'[symmetric])
                        by(simp_all add: ff_ix ff_iy True)
                finally show ?thesis .
              next
                case False
                then have yx: "index init y < index init x" using ix_iy by auto
                have man: "?I =  {index init y, index init x}" by auto
                have "nths ?A {index init y, index init x}  = [?A!index init y, ?A!index init x]"
                      apply(rule nths_project')
                        by(simp_all add: ff_ix ff_iy yx)
                also have " = [?B!index init y, ?B!index init x]"
                  unfolding sf_init using flip_other ff_ix ff_iy ff_q iq_ix iq_iy by auto
                also have " = nths ?B {index init y, index init x}"
                      apply(rule nths_project'[symmetric])
                        by(simp_all add: ff_ix ff_iy yx)
                finally show ?thesis by(simp add: man)
              qed


              have snd: "Lxy (step (?s) (q)
                  (if ?b ! index ?m (q) then 0 else length (?s),
                   [])) {x, y} = Lxy (?s) {x, y}" (is "Lxy ?A {x,y} = Lxy ?B {x,y}")
              proof (cases "x < y in ?B")
                case True
                note B=this
                then have A: "x<y in ?A" apply(auto simp add: step_def split_def)
                  apply(rule x_stays_before_y_if_y_not_moved_to_front)
                    by(simp_all add: a s_dist qny[symmetric] qininit)

                have "Lxy ?A {x,y} = [x,y]"
                  apply(rule Lxy_project)
                    by(simp_all add: xny set_step distinct_step A s_dist a)
                also have "... = Lxy ?B {x,y}"
                  apply(rule Lxy_project[symmetric])
                    by(simp_all add: xny B s_dist a)
                finally show ?thesis .
              next
                case False
                then have B: "y < x in ?B" using not_before_in[OF s_xin s_yin] xny by simp
                then have A: "y < x in ?A " apply(auto simp add: step_def split_def)
                  apply(rule x_stays_before_y_if_y_not_moved_to_front)
                    by(simp_all add: a s_dist qnx[symmetric] qininit)
                have man: "{x,y} = {y,x}" by auto
                have "Lxy ?A {y,x} = [y,x]"
                  apply(rule Lxy_project)
                    by(simp_all add: xny[symmetric] set_step distinct_step A s_dist a)
                also have "... = Lxy ?B {y,x}"
                  apply(rule Lxy_project[symmetric])
                    by(simp_all add: xny[symmetric] B s_dist a)
                finally show ?thesis using man by auto
              qed
 
              show ?case by(simp add: fstfst snd)
            qed simp
        also have " = config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y})"
          using iH by (auto simp: split_def)
        also have " = ?R (qs@[q])"
          using False by(simp add: Lxy_snoc)
        finally show ?thesis by (simp add: split_def)
      qed 
    qed
    } note strong=this

  { 
    fix n::nat 
    have "Pbefore_in x y BIT qs init = 
        map_pmf (λp. x < y in fst p)
            (map_pmf (λ(l, (w, i)). (Lxy l {x, y}, (nths w {index init x, index init y}, Lxy init {x, y})))
                  (config_rand BIT init qs))" 
                  unfolding Pbefore_in_def apply(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf split_def)
                  apply(rule bind_pmf_cong)
                    apply(simp)
                    proof (goal_cases)
                      case (1 z)
                      let ?s = "fst z"
                      from 1 have u: "set (?s) = set init" using config_rand[of BIT, simplified] by metis
                      from 1 have v: "distinct (?s)" using dinit config_rand[of BIT, simplified] by metis
                      have "(x < y in ?s) = (x < y in Lxy (?s) {x, y})"
                        apply(rule Lxy_mono)
                          using u xyininit apply(simp)
                          using v by simp
                      then show ?case by simp
                    qed
     also have " = map_pmf (λp. x < y in fst p) (config_rand BIT (Lxy init {x, y}) (Lxy qs {x, y}))"
        apply(subst strong) using assms by simp_all
     also have " = Pbefore_in x y BIT (Lxy qs {x, y}) (Lxy init {x, y})" unfolding Pbefore_in_def by simp
     finally have "Pbefore_in x y BIT qs init =
        Pbefore_in x y BIT (Lxy qs {x, y}) (Lxy init {x, y})" .      
  
  } note fine=this

  with assms show ?thesis by simp
qed
        

theorem BIT_pairwise: "pairwise BIT"
apply(rule pairwise_property_lemma)
  apply(rule BIT_pairwise') 
    by(simp_all add: BIT_step_def)


end

Theory BIT_2comp_on2

(*  Title:       BIT is 1.75 competitive on lists of length 2
    Author:      Max Haslbeck
*)
section "BIT is 1.75 competitive on lists of length 2"

theory BIT_2comp_on2
imports BIT Phase_Partitioning
begin

subsection "auxliary lemmas"

subsubsection "E_bernoulli3›"

lemma E_bernoulli3: assumes "0<p"
    and "p<1"
    and "finite (set_pmf (bind_pmf (bernoulli_pmf p) f))"
    shows "E (bind_pmf (bernoulli_pmf p) f) = E(f True)*p + E(f False)*(1-p)" (is "?L = ?R")
proof -

  have T: "(a(x. set_pmf (f x)). (a * pmf (f True) a))
            = E(f True)"
    unfolding E_def
    apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
      using assms apply(simp)
      using assms apply(simp add: set_pmf_bernoulli) apply blast
      using assms by(simp add: set_pmf_bernoulli mult_ac) 
  have F: "(a(x. set_pmf (f x)). (a * pmf (f False) a))
            = E(f False)"
    unfolding E_def
    apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
      using assms apply(simp)
      using assms apply(simp add: set_pmf_bernoulli) apply blast
      using assms by(simp add: set_pmf_bernoulli mult_ac) 

  have "?L = (a(x. set_pmf (f x)).
       a *
       (pmf (f True) a * p +
        pmf (f False) a * (1 - p)))"  
  unfolding E_def 
  apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
    using assms apply(simp)
    apply(simp)
    using assms apply(simp add: set_pmf_bernoulli )
    by(simp add: pmf_bind mult_ac)
  also have " = (a(x. set_pmf (f x)). (a * pmf (f True) a * p)
                                    + (a * pmf (f False) a * (1 - p)))"
    apply(rule sum.cong) apply(simp) by algebra
  also have " = (a(x. set_pmf (f x)). (a * pmf (f True) a * p))
                  + (a(x. set_pmf (f x)). (a * pmf (f False) a * (1 - p)))"
    by (simp add: sum.distrib)
  also have " = (a(x. set_pmf (f x)). (a * pmf (f True) a)) * p
                  + (a(x. set_pmf (f x)). (a * pmf (f False) a )) * (1 - p)"
    by (simp add: sum_distrib_right)    
  also have " = ?R" unfolding T F by simp
  finally show ?thesis .
qed 


subsubsection "types of configurations"

definition "type0 init x y = do {
                  (a::bool)  (bernoulli_pmf 0.5);
                  (b::bool)  (bernoulli_pmf 0.5);
                  return_pmf  ([x,y], ([a,b],init))
                }"

definition "type1 init x y = do {
                  (a::bool)  (bernoulli_pmf 0.5);
                  (b::bool)  (bernoulli_pmf 0.5);
                  return_pmf ( if ~[a,b]!(index init x)[a,b]!(index init y) then ([y,x], ([a,b],init))
                         else ([x,y], ([a,b],init)))
                }"

definition "type3 init x y = do {
                  (a::bool)  (bernoulli_pmf 0.5);
                  (b::bool)  (bernoulli_pmf 0.5);
                  return_pmf ( if [a,b]!(index init x)~[a,b]!(index init y) then ([x,y], ([a,b],init))
                         else ([y,x], ([a,b],init)))
                }"

definition "type4 init x y = do {
                  (a::bool)  (bernoulli_pmf 0.5);
                  (b::bool)  (bernoulli_pmf 0.5);
                  return_pmf ( if ~[a,b]!(index init y) then ([x,y], ([a,b],init))
                         else ([y,x], ([a,b],init)))
                }"

definition "BIT_inv s x i == (s = (type0 i x (hd (filter (λy. yx) i) )))"

lemma BIT_inv2: "xy  z{x,y}  BIT_inv s z [x,y] = (s= type0 [x,y] z (other z x y))"
  unfolding BIT_inv_def by(auto simp add: other_def)

subsubsection "cost of BIT"

lemma costBIT_0x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type0 [x0, y0] x y 
       (λs. BIT_step s x 
            (λ(a, is'). return_pmf (real (tp (fst s) x a))))) = 0"
using assms apply(auto)
  apply(simp_all add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_0y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type0 [x0, y0] x y 
       (λs. BIT_step s y 
            (λ(a, is'). return_pmf (real (tp (fst s) y a))))) = 1"
using assms apply(auto)
  apply(simp_all add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_1x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type1 [x0, y0] x y 
       (λs. BIT_step s x 
            (λ(a, is'). return_pmf (real (tp (fst s) x a))))) = 1/4"
using assms apply(auto)
  apply(simp_all add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_1y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type1 [x0, y0] x y 
       (λs. BIT_step s y 
            (λ(a, is'). return_pmf (real (tp (fst s) y a))))) = 3/4"
using assms apply(auto)
  apply(simp_all add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done
  
lemma costBIT_3x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type3 [x0, y0] x y 
       (λs. BIT_step s x 
            (λ(a, is'). return_pmf (real (tp (fst s) x a))))) = 3/4"
using assms apply(auto)
  apply(simp_all add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_3y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type3 [x0, y0] x y 
       (λs. BIT_step s y 
            (λ(a, is'). return_pmf (real (tp (fst s) y a))))) = 1/4"
using assms apply(auto)
  apply(simp_all add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_4x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type4 [x0, y0] x y 
       (λs. BIT_step s x 
            (λ(a, is'). return_pmf (real (tp (fst s) x a))))) = 0.5"
using assms apply(auto)
  apply(simp_all add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemma costBIT_4y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows
  "E (type4 [x0, y0] x y 
       (λs. BIT_step s y 
            (λ(a, is'). return_pmf (real (tp (fst s) y a))))) = 0.5"
using assms apply(auto)
  apply(simp_all add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 tp_def)
  done

lemmas costBIT = costBIT_0x costBIT_0y costBIT_1x costBIT_1y costBIT_3x costBIT_3y costBIT_4x costBIT_4y

subsubsection "state transformation of BIT"

abbreviation "BIT_Step s x == (s  (λs. BIT_step s x  (λ(a, is'). return_pmf (step (fst s) x a, is'))))"

lemma oneBIT_step0x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type0 [x0, y0] x y) x = type0 [x0, y0] x y"
  using assms
  apply(simp add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)   
    done 

lemma oneBIT_step0y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type0 [x0, y0] x y) y = type4 [x0, y0] x y"
  using assms
  apply(simp add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type4_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type4_def)   
    done 

lemma oneBIT_step1x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type1 [x0, y0] x y) x = type0 [x0, y0] x y"
  using assms
  apply(simp add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)   
    done 

lemma oneBIT_step1y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type1 [x0, y0] x y) y = type3 [x0, y0] x y"
  using assms
  apply(simp add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type3_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type3_def)   
    done 

lemma oneBIT_step3x: 
    assumes "xy" "x:{x0,y0}" "y:{x0,y0}"
    shows "BIT_Step (type3 [x0, y0] x y) x = type1 [x0, y0] x y"
  using assms
  apply(simp add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type1_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type1_def)   
    done

lemma oneBIT_step3y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type3 [x0, y0] x y) y = type0 [x0, y0] y x"
  using assms
  apply(simp add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)   
    done 

lemma oneBIT_step4x: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type4 [x0, y0] x y) x =  type1 [x0, y0] x y"
  using assms
  apply(simp add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type1_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type1_def)   
    done 

lemma oneBIT_step4y: 
    assumes "xy" "x : {x0,y0}" "y{x0,y0}"
    shows "BIT_Step (type4 [x0, y0] x y) y = type0 [x0, y0] y x"
  using assms
  apply(simp add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe) 
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)   
    done 
       
lemmas oneBIT_step = oneBIT_step0x oneBIT_step0y oneBIT_step1x oneBIT_step1y oneBIT_step3x oneBIT_step3y oneBIT_step4x oneBIT_step4y      
        
subsection "Analysis of the four phase forms"

subsubsection "yx"
 
lemma bit_yx: assumes "x  y" 
      and kas: "init  {[x,y],[y,x]}"
      and "qs  lang (Star(Times (Atom y) (Atom x))) "
   shows "Tp_on_rand' BIT (type1 init x y) (qs@r) = 0.75 * length qs + Tp_on_rand' BIT (type1 init x y) r 
     config'_rand BIT (type1 init x y) qs  = (type1 init x y)"
proof -
  from assms have "qs  star ({[y]} @@ {[x]})" by (simp)
  from this assms show ?thesis
  proof (induct qs rule: star_induct)
    case (append u v)
    then have uyx: "u = [y,x]" by auto 
     
    have yy: "Tp_on_rand' BIT (type1 init x y)  (v @ r)  = 0.75*length v + Tp_on_rand' BIT (type1 init x y) r  
             config'_rand BIT  (type1 init x y) v = (type1 init x y)"
        apply(rule append(3)) 
          apply(fact)+
          using append(2,6) by(simp_all)
     
    have s2: "config'_rand BIT  (type1 init x y) [y,x] = (type1 init x y)"
      using kas assms(1) by (auto simp add: oneBIT_step )
                             
    have ta: "Tp_on_rand' BIT (type1 init x y) u = 1.5"
      using kas assms(1)
        by(auto simp add: uyx oneBIT_step costBIT_1y costBIT_3x)                             
       
    have config: "config'_rand BIT  (type1 init x y) (u @ v)
          = type1 init x y" by (simp only: config'_rand_append s2 uyx yy)

    have "Tp_on_rand' BIT (type1 init x y) (u @ (v @ r))  
        = Tp_on_rand' BIT (type1 init x y) u  + Tp_on_rand' BIT ( config'_rand BIT (type1 init x y)  u) (v@r) "
          by (simp only: T_on_rand'_append)
    also have " =  Tp_on_rand' BIT  (type1 init x y) u + Tp_on_rand' BIT (type1 init x y) (v@r) "
      unfolding uyx by(simp only: s2) 
    also have " = Tp_on_rand' BIT (type1 init x y) u  + 0.75*length v + Tp_on_rand' BIT (type1 init x y) r "
        by(simp only: yy) 
    also have " = 2*0.75 + 0.75*length v + Tp_on_rand' BIT (type1 init x y) r " by(simp add: ta) 
    also have " = 0.75 * (2+length v) + Tp_on_rand' BIT (type1 init x y) r"
      by (simp add: ring_distribs del: add_2_eq_Suc' add_2_eq_Suc)
    also have " = 0.75 * length (u @ v) + Tp_on_rand' BIT (type1 init x y) r"
      using uyx by simp
    finally show ?case using config by simp 
  qed simp
qed


subsubsection "(yx)*yx"

lemma bit_yxyx: assumes "x  y" and kas: "init  {[x,y],[y,x]}" and
      "qs  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
   shows "Tp_on_rand' BIT (type0 init x y) (qs@r) = 0.75 * length qs + Tp_on_rand' BIT (type1 init x y) r 
     config'_rand BIT (type0 init x y) qs  = (type1 init x y)"
proof -
  obtain u v where uu: "u  lang (Times (Atom y) (Atom x))"
              and vv: "v  lang (seq[ Star(Times (Atom y) (Atom x))])"
              and qsuv: "qs = u @ v" 
  using assms(3) by (auto simp: conc_def)  

  from uu have uyx: "u = [y,x]" by(auto)

  from qsuv uyx have vqs: "length v = length qs - 2" by auto
  from qsuv uyx  have vqs2: "length v + 2 = length qs" by auto

  have s2: "config'_rand BIT  (type0 init x y) [y,x] = (type1 init x y)"
     using kas assms(1) by(auto simp add: oneBIT_step) 
                            
  have ta: "Tp_on_rand' BIT (type0 init x y) u = 1.5"
    using kas assms(1) by (auto simp add: uyx oneBIT_step costBIT) 
                  
  have tat: "Tp_on_rand' BIT (type1 init x y) (v @ r) =   0.75*length v + Tp_on_rand' BIT (type1 init x y) r
             config'_rand BIT (type1 init x y) v = (type1 init x y)"
        apply(rule bit_yx)
      apply(fact)+
      using vv by(simp_all)


  have config: "config'_rand BIT (type0 init x y) (u @ v) = type1 init x y"
    by(simp only: config'_rand_append s2 uyx tat)
     
  have "Tp_on_rand' BIT (type0 init x y) (u @ (v @ r)) 
        = Tp_on_rand' BIT (type0 init x y) u + Tp_on_rand' BIT (config'_rand BIT (type0 init x y) u) (v@r)" by (simp only: T_on_rand'_append)
also
  have " =  Tp_on_rand' BIT (type0 init x y) u + Tp_on_rand' BIT (type1 init x y) (v@r)" by(simp only: uyx s2) 
also
  have " = Tp_on_rand' BIT (type0 init x y) u + 0.75*length v + Tp_on_rand' BIT (type1 init x y) r" by(simp only: tat) 
also
  have " = 2*0.75 + 0.75*length v + Tp_on_rand' BIT (type1 init x y) r" by(simp add: ta) 
also
  have " = 0.75 * (2+length v) + Tp_on_rand' BIT (type1 init x y) r" by (simp add: ring_distribs del: add_2_eq_Suc' add_2_eq_Suc) 
also
  have " = 0.75 * length (u @ v) + Tp_on_rand' BIT (type1 init x y) r" using uyx by simp
finally
  show ?thesis using qsuv config by simp
qed

  
subsubsection x^+..›

lemma BIT_x: assumes "xy"
       "init  {[x,y],[y,x]}" "qs  lang (Plus (Atom x) One)"
 shows "Tp_on_rand' BIT (type0 init x y) (qs@r) = Tp_on_rand' BIT (type0 init x y) r 
     config'_rand BIT  (type0 init x y) qs = (type0 init x y)"
proof - 
  have s: "config'_rand BIT (type0 init x y) qs = type0 init x y"
    using assms by (auto simp add: oneBIT_step)

  have t: "Tp_on_rand' BIT (type0 init x y) qs = 0"
    using assms by (auto simp add: costBIT)

  show ?thesis using s t by(simp add: T_on_rand'_append)
qed
        

subsubsection "Phase Form A"

lemma BIT_a: assumes "x  y"
    " init  {[x,y],[y,x]}"
   "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "config'_rand BIT (type0 init x y) qs = (type0 init y x)" (is ?C)
    and b: "Tp_on_rand' BIT (type0 init x y) qs = 1.5" (is ?T) 
proof - 
  from assms(3) have alt: "qs = [x,y,y]  qs = [y,y]" apply(simp) by fastforce
  show ?C
    using assms(1,2) alt by (auto simp add: oneBIT_step)
  show ?T
    using assms(1,2) alt by(auto simp add: oneBIT_step costBIT) 
qed
 
lemma bit_a: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" "qs  lang (seq [Plus (Atom x) One, Atom y, Atom y])"
 shows  
    "Tp_on_rand' BIT s qs   1.75 * Tp [x,y] qs (OPT2 qs [x,y]) 
        BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]
       Tp_on_rand' BIT s qs = 1.5"
proof -
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have p: "Tp_on_rand' BIT s qs = 1.5"
    unfolding s 
    apply(safe)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done
  with OPT2_A[OF assms(1,5)] have BIT: "Tp_on_rand' BIT s qs  1.75 * Tp [x, y] qs (OPT2 qs [x, y])" by auto


  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s 
    apply(safe)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done 
   
  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def) 

  then show ?thesis using BIT s p by simp
qed  

lemma bit_a'': " a  b 
         {a, b} = {x, y} 
         BIT_inv s a [x, y] 
         set qs  {a, b} 
         qs  lang (seq [question (Atom a), Atom b, Atom b]) 
         BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y]  Tp_on_rand' BIT s qs = 1.5"
using bit_a[of a b x y] by blast


subsubsection "Phase Form B"

lemma BIT_b: assumes A: "x  y"
       "init  {[x,y],[y,x]}"
    "v  lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
    shows "Tp_on_rand' BIT (type0 init x y) v = 0.75 * length v - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init y x)" (is ?C)
proof -
  have lenvmod: "length v mod 2 = 0"
  proof -
    from assms(3) have "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by(simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[y]} @@ {[y]}" by (metis concE)
    then have "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length v = 4+length q" by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b show "length v mod 2 = 0" by auto
  qed
 
  from assms(3) have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b  lang (seq[Atom y, Atom y])"
                      and vab: "v = a @ b" 
                      by(erule concE) 
  then have bb: "b=[y,y]" by auto 
  from vab bb have lenv: "length v = length a + 2" by auto
 
  from bit_yxyx[OF assms(1,2) aa] have stars: "Tp_on_rand' BIT (type0 init x y) (a @ b)  = 0.75 * length a + Tp_on_rand' BIT (type1 init x y) b"
                             and s2: "config'_rand BIT (type0 init x y) a = type1 init x y"  by fast+

  have t: "Tp_on_rand' BIT (type1 init x y) b = 1"
    using assms(1,2) by (auto simp add: oneBIT_step  costBIT bb)   

  have s: "config'_rand BIT  (type1 init x y) [y, y] = type0 init y x" 
    using assms(1,2) by (auto simp add: oneBIT_step) 

  have config: "config'_rand BIT (type0 init x y) (a @ b) = type0 init y x"
    by (simp only: config'_rand_append s2 vab bb s)
 
  have calc: "3 * Suc (Suc (length a)) / 4 - 1 / 2 = 3 * (2+length a) / 4 - 1 / 2" by simp

  from t stars have "Tp_on_rand' BIT (type0 init x y) (a @ b) = 0.75 * length a + 1" by auto
  then show "Tp_on_rand' BIT  (type0 init x y) v = 0.75 * length v - 0.5"
    unfolding lenv by(simp add: vab ring_distribs del: add_2_eq_Suc')
  from config vab show ?C by simp
qed


lemma bit_b''1: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
          Tp_on_rand' BIT s qs  = 0.75 * length qs - 0.5"
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs = 0.75 * length qs - 0.5"
    unfolding s 
    apply(safe)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s 
    apply(safe)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done 
   
  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def) 

  show ?thesis using BIT config by simp
qed


lemma BIT_b2: assumes A: "x  y"
       "init  {[x,y],[y,x]}"
    "v  lang (seq [Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
    shows "Tp_on_rand' BIT (type0 init x y) v = 0.75 * (length v - 1) - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init y x)" (is ?C)
proof - 
  from assms(3) obtain w where  vw: "v = [x]@w" and
          w: "w  lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
          by(auto)          
  have c1: "config'_rand BIT (type0 init x y) [x] = type0 init x y"
      using assms by(auto simp add: oneBIT_step)
  have t1: "Tp_on_rand' BIT (type0 init x y) [x] = 0"
      using assms by(auto simp add: costBIT)
  show "Tp_on_rand' BIT (type0 init x y) v
      = 0.75 * (length v - 1) - 0.5"
      unfolding vw apply(simp only: T_on_rand'_append c1 BIT_b[OF assms(1,2) w] t1)
        by (simp)
  show "config'_rand BIT (type0 init x y) v = (type0 init y x)"
    unfolding vw by(simp only: config'_rand_append c1 BIT_b[OF assms(1,2) w])
qed

lemma bit_b''2: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
          Tp_on_rand' BIT s qs  = 0.75 * (length qs - 1) - 0.5"
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs = 0.75 * (length qs-1) - 0.5"
    unfolding s 
    apply(safe)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s 
    apply(safe)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done 
   
  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def) 

  show ?thesis using BIT config by simp
qed

lemma bit_b: assumes "x  y"
      "init  {[x,y],[y,x]}"
   "qs  lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows  "Tp_on_rand' BIT (type0 init x y) qs  1.75 * Tp [x,y] qs (OPT2 qs [x,y])"
  and "config'_rand BIT (type0 init x y) qs = type0 init y x"
proof - 
  obtain u v where uu: "u  lang (Plus (Atom x) One)"
        and vv: "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
        and qsuv: "qs = u @ v" 
        using assms
        by (auto simp: conc_def) 
  have lenv: "length v mod 2 = 0  last v = y  v[]"
  proof -
    from vv have "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by simp
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r {[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length v = 4+length q" by auto

    have "last v = last r" using pqr rr by auto
    then have c: "last v = y" using rr by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b c show ?thesis by auto
  qed
        
  from vv have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                    and "b  lang (seq[Atom y, Atom y])"
                    and vab: "v = a @ b" 
                      by(erule concE)  

  from BIT_x[OF assms(1,2) uu] have u_t: "Tp_on_rand' BIT (type0 init x y) (u @ v)  = Tp_on_rand' BIT (type0 init x y) v"
      and u_c: "config'_rand BIT (type0 init x y) u = type0 init x y" by auto
  from BIT_b[OF assms(1,2) vv] have b_t: "Tp_on_rand' BIT (type0 init x y) v  = 0.75 * length v - 0.5"
      and  b_c: "config'_rand BIT (type0 init x y) v = (type0 init y x)" by auto
 
  have BIT: "Tp_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5"
    by(simp add: qsuv u_t b_t)
          
  (* OPT *)

  from uu have uuu: "u=[]  u=[x]" by auto
  have OPT: "Tp [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+

  from lenv have "v  []"  "last v = y" by auto
  then have 1:  "last qs = y" using last_appendR qsuv by simp 
  then have 2: "other (last qs) x y = x" unfolding other_def by simp

  show "Tp_on_rand' BIT (type0 init x y) qs  1.75 * Tp [x,y] qs (OPT2 qs [x,y])"
    using BIT OPT lenv by auto

  (* config *)

  show "config'_rand BIT (type0 init x y) qs = type0 init y x"
    by (auto simp add: config'_rand_append qsuv u_c b_c)
qed



lemma bit_b'': assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows  
    "Tp_on_rand' BIT s qs   1.75 * Tp [x,y] qs (OPT2 qs [x,y]) 
        BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]" 
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs  1.75 * Tp [x, y] qs (OPT2 qs [x, y])"
    unfolding s 
    apply(safe)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done 

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s 
    apply(safe)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done 
   
  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def) 

  then show ?thesis using BIT s by simp
qed

lemma bit_b''': " a  b 
         {a, b} = {x, y} 
         BIT_inv s a [x, y] 
         set qs  {a, b} 
         qs  lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y]) 
         BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y]  Tp_on_rand' BIT s qs = 1.5"
using bit_a[of a b x y] oops

subsubsection "Phase Form C"

lemma BIT_c: assumes "x  y"
       "init  {[x,y],[y,x]}"
    "v  lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
    shows "Tp_on_rand' BIT (type0 init x y) v = 0.75 * length v - 0.5"
      and "config'_rand BIT  (type0 init x y) v = (type0 init x y)" (is ?C)
proof -        
  have A: "xy"  using assms by auto
 
  from assms(3) have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom x])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b  lang (seq[Atom x])"
                      and vab: "v = a @ b" 
                      by(erule concE) 
  then have bb: "b=[x]" by auto
  from aa have lena: "length a > 0" by auto
  from vab bb have lenv: "length v = length a + 1" by auto
 
  from bit_yxyx assms(1,2) aa have stars: "Tp_on_rand' BIT (type0 init x y) (a @ b)  = 0.75 * length a + Tp_on_rand' BIT (type1 init x y) b"
                             and s2: "config'_rand BIT (type0 init x y) a = type1 init x y"  by fast+

  have t: "Tp_on_rand' BIT (type1 init x y) b = 1/4"
    using assms(1,2) by (auto simp add: bb costBIT)  
 

  have s: "config'_rand BIT  (type1 init x y) b = type0 init x y" 
    using assms(1,2) by (auto simp add: bb oneBIT_step1x )    


  have config: "config'_rand BIT  (type0 init x y) (a @ b) = type0 init x y"
    by (simp only: config'_rand_append s2 vab s)
 
  have calc: "3 * Suc (Suc (length a)) / 4 - 1 / 2 = 3 * (2+length a) / 4 - 1 / 2" by simp

  from t stars have "Tp_on_rand' BIT (type0 init x y) (a @ b) = 0.75 * length a + 1/4" by auto
  then show "Tp_on_rand' BIT  (type0 init x y) v = 0.75 * length v - 0.5" unfolding lenv 
    by(simp add: vab ring_distribs del: add_2_eq_Suc')
  from config vab show ?C by simp
qed

lemma bit_c''1: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
          Tp_on_rand' BIT s qs  = 0.75 * length qs - 0.5"
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs = 0.75 * length qs - 0.5"
    unfolding s 
    apply(safe) 
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s 
    apply(safe)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done 
   
  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def) 

  show ?thesis using BIT config by simp
qed
           
lemma bit_c: assumes "x  y"
      "init  {[x,y],[y,x]}"
   "qs  lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows  "Tp_on_rand' BIT (type0 init x y) qs  1.75 * Tp [x,y] qs (OPT2 qs [x,y])"
  and "config'_rand BIT (type0 init x y) qs = type0 init x y"
proof -
  obtain u v where uu: "u  lang (Plus (Atom x) One)"
        and vv: "v  lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
        and qsuv: "qs = u @ v" 
        using assms
        by (auto simp: conc_def) 
  have lenv: "length v mod 2 = 1  length v  3  last v = x"
  proof -
    from vv have "v  ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by auto
    then obtain p q r where pqr: "v=p@q@r" and "p({[y]} @@ {[x]})"
              and q: "q  star ({[y]} @@ {[x]})" and "r  {[x]}" by (metis concE)
    then have rr: "p = [y,x]"  "r=[x]" by auto
    with pqr have a: "length v = 3+length q" by auto

    have "last v = last r" using pqr rr by auto
    then have c: "last v = x" using rr by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)    
    from a b c show "length v mod 2 = 1  length v  3  last v = x" by auto
  qed
        
  from vv have "v  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom x])" by (auto simp: conc_def)
  then obtain a b where aa: "a  lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b  lang (seq[Atom x])"
                      and vab: "v = a @ b" 
                      by(erule concE)  

  from BIT_x[OF assms(1,2) uu] have u_t: "Tp_on_rand' BIT (type0 init x y)  (u @ v)  = Tp_on_rand' BIT (type0 init x y) v"
      and u_c: "config'_rand BIT (type0 init x y) u = type0 init x y" by auto
  from BIT_c[OF assms(1,2) vv] have b_t: "Tp_on_rand' BIT (type0 init x y) v  = 0.75 * length v - 0.5"
      and  b_c: "config'_rand BIT (type0 init x y) v = (type0 init x y)" by auto
 
  have BIT: "Tp_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5"
    by(simp add: qsuv u_t b_t)
          
  (* OPT *)

  from uu have uuu: "u=[]  u=[x]" by auto
  from vv have vvv: "v  lang (seq
          [Atom y, Atom x,
           Star (Times (Atom y) (Atom x)),
           Atom x])" by(auto simp: conc_def)
  have OPT: "Tp [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+


  from lenv have "v  []"  "last v = x" by auto
  then have 1:  "last qs = x" using last_appendR qsuv by simp 
  then have 2: "other (last qs) x y = y" unfolding other_def by simp



  have vgt3: "length v  3" using lenv by simp
  have "Tp_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5" using BIT by simp
also
  have "  1.75 * (length v - 1)/2"
  proof -
    have "10 + 6 * length v  7 * Suc (length v) 
         10 + 6 * length v  7 * length v + 7" by auto
    also have "  3  length v" by auto
    also have "  True" using vgt3 by auto
    finally have A: " 6 * length v - 4  7 * (length v - 1)" by simp
    show ?thesis apply(simp) using A by linarith 
  qed    
also
  have " = 1.75 * (length v div 2)"
  proof -
    from div_mult_mod_eq have "length v = length v div 2 * 2 + length v mod 2" by auto
    with lenv have "length v = length v div 2 * 2 + 1" by auto 
    then have "(length v - 1) / 2 = length v div 2" by simp
    then show ?thesis by simp
  qed
also
  have " = 1.75 * Tp [x, y] qs (OPT2 qs [x, y])" using OPT by auto
finally
  show "Tp_on_rand' BIT (type0 init x y) qs  1.75 * Tp [x,y] qs (OPT2 qs [x,y])"
    using BIT OPT lenv   1 2  by auto

  (* config *)

  show "config'_rand BIT  (type0 init x y) qs  = type0 init x y"
    by (auto simp add: config'_rand_append qsuv u_c b_c)
qed

lemma bit_c'': assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows  
    "Tp_on_rand' BIT s qs   1.75 * Tp [x,y] qs (OPT2 qs [x,y]) 
        BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]" 
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs  1.75 * Tp [x, y] qs (OPT2 qs [x, y])"
    unfolding s 
    apply(safe)
      apply(rule bit_c )
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done 

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s 
    apply(safe)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done 
   
  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def) 

  then show ?thesis using BIT s by simp
qed  




lemma BIT_c2: assumes A: "x  y"
       "init  {[x,y],[y,x]}"
    "v  lang (seq [Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
    shows "Tp_on_rand' BIT (type0 init x y) v = 0.75 * (length v - 1) - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init x y)" (is ?C)
proof - 
  from assms(3) obtain w where  vw: "v = [x]@w" and
          w: "w  lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
          by(auto)          
  have c1: "config'_rand BIT (type0 init x y) [x] = type0 init x y"
      using assms by(auto simp add: oneBIT_step)
  have t1: "Tp_on_rand' BIT (type0 init x y) [x] = 0"
      using assms by(auto simp add: costBIT)
  show "Tp_on_rand' BIT (type0 init x y) v
      = 0.75 * (length v - 1) - 0.5"
      unfolding vw apply(simp only: T_on_rand'_append c1 BIT_c[OF assms(1,2) w] t1)
        by (simp)
  show "config'_rand BIT (type0 init x y) v = (type0 init x y)"
    unfolding vw by(simp only: config'_rand_append c1 BIT_c[OF assms(1,2) w])
qed

lemma bit_c''2: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" 
    "qs  lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
          Tp_on_rand' BIT s qs  = 0.75 * (length qs - 1) - 0.5"
proof -  
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "Tp_on_rand' BIT s qs = 0.75 * (length qs-1) - 0.5"
    unfolding s 
    apply(safe)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s 
    apply(safe)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done 
   
  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def) 

  show ?thesis using BIT config by simp
qed


subsubsection "Phase Form D"
 
lemma bit_d: assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" "qs  lang (seq [Atom x, Atom x])"
  shows "Tp_on_rand' BIT s qs  175 / 102 * real (Tp [x, y] qs (OPT2 qs [x, y])) 
    BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
     Tp_on_rand' BIT s qs = 0"
proof - 
  from assms have qs: "qs = [x,x]" by auto
  then have OPT: "Tp [x, y] qs (OPT2 qs [x, y]) = 0" by (simp add: tp_def step_def)
   
  from assms have f: "x0y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast
    
  from assms(1,2) have kas: "[x,y] = [x0,y0]  [x,y] = [y0,x0]" by auto
 
  have BIT: "Tp_on_rand' BIT (type0 [x0,y0] x y) qs = 0"
    using kas assms(1,2) by (auto simp add: qs oneBIT_step costBIT) 

  have lqs: "last qs = x" "last qs  {x0,y0}" using assms(2,4) qs by auto 

  have inv: "config'_rand BIT s qs = type0 [x0, y0] x y"
    using kas assms(1,2) by (auto simp add: qs s  oneBIT_step0x) 
   
  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def) 
    
  then show ?thesis using BIT s by(auto)
qed

lemma bit_d': assumes 
    "x  y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs  {x, y}" "qs  lang (seq [Atom x, Atom x])"
  shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] 
     Tp_on_rand' BIT s qs = 0"
using bit_d[OF assms] by blast



subsection "Phase Partitioning"

lemma BIT_inv_initial: assumes "(x::nat)  y"
    shows "BIT_inv (map_pmf (Pair [x, y]) (fst BIT [x, y])) x [x, y]"
using assms(1) apply(simp add: BIT_inv2 BIT_init_def type0_def)
      apply(simp add: map_pmf_def other_def bind_return_pmf bind_assoc_pmf)
      using bind_commute_pmf by fast

lemma D'': assumes "qs  Lxx a b"
    "a  b" "{a, b} = {x, y}" "BIT_inv s a [x, y]"
    "set qs  {a, b}"
 shows "Tp_on_rand' BIT s qs  175 / 102 * real (Tp [a, b] qs (OPT2 qs [a, b])) 
    BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y]"
 apply(rule LxxE[OF assms(1)])
  using bit_d[OF assms(2-5)] apply(simp)
  apply(rule bit_b''[OF assms(2-5)]) apply(simp)
  apply(rule bit_c''[OF assms(2-5)]) apply(simp) 
  using bit_a[OF assms(2-5)] apply(simp)
  done

theorem BIT_175comp_on_2:
    assumes "(x::nat)  y" "set σ  {x,y}"     
     shows "Tp_on_rand BIT [x,y] σ   1.75 * real (Tp_opt [x,y] σ) + 1.75" 
proof (rule Phase_partitioning_general[where P=BIT_inv], goal_cases)
  case 4
  show "BIT_inv (map_pmf (Pair [x, y]) (fst BIT [x, y])) x [x, y]"
   by (rule BIT_inv_initial[OF assms(1)])
next
  case (5 a b qs s)
  then show ?case by(rule D'')
qed (simp_all add: assms)  
 
end

Theory Comb

(*  Title:       COMB
    Author:      Max Haslbeck
*) 

section "COMB"

theory Comb
imports TS BIT_2comp_on2 BIT_pairwise
begin


(*  state of BIT: bool list     bit string
    state of TS: nat list       history
*)

subsection "Definition of COMB"

type_synonym CombState = "(bool list * nat list) + (nat list)" 
                          
definition COMB_init :: "nat list  (nat state, CombState) alg_on_init" where
  "COMB_init h init = 
        Sum_pmf 0.8 (fst BIT init) (fst (embed (rTS h)) init)"

lemma COMB_init[simp]: "COMB_init h init =
                do {
                    (b::bool)  (bernoulli_pmf 0.8);
                    (xs::bool list)  Prob_Theory.bv (length init);
                    return_pmf (if b then Inl (xs, init) else Inr h)
                  }" 
 apply(simp add: bind_return_pmf COMB_init_def BIT_init_def rTS_def
              bind_assoc_pmf )
 unfolding map_pmf_def Sum_pmf_def
 apply(simp add: if_distrib bind_return_pmf bind_assoc_pmf )
    apply(rule bind_pmf_cong) 
     by(auto simp add: bind_return_pmf bind_assoc_pmf)

definition COMB_step :: "(nat state, CombState, nat, answer) alg_on_step" where
"COMB_step s q = (case snd s of Inl b  map_pmf (λ((a,b),c). ((a,b),Inl c)) (BIT_step (fst s, b) q)
                              | Inr b  map_pmf (λ((a,b),c). ((a,b),Inr c)) (return_pmf (TS_step_d (fst s, b) q)))"
            
definition "COMB h = (COMB_init h, COMB_step)"
 

subsection "Comb 1.6-competitive on 2 elements"
 
abbreviation "noc == (%x. case x of Inl (s,is)  (s,Inl is) | Inr (s,is)  (s,Inr is) )"
abbreviation "con == (%(s,is). case is of Inl is  Inl (s,is) | Inr is  Inr (s,is) )"

definition "inv_COMB s x i == (Da Db. finite (set_pmf Da)  finite (set_pmf Db) 
      (map_pmf con s) = Sum_pmf 0.8 Da Db  BIT_inv Da x i  TS_inv Db x i)"

lemma noccon: "noc o con = id"
  apply(rule ext)
  apply(case_tac x) by(auto simp add: sum.case_eq_if)
 
lemma connoc: "con o noc = id"
  apply(rule ext)
  apply(case_tac x) by(auto simp add: sum.case_eq_if) 

lemma obligation1': assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    shows "config'_rand (COMB h) s qs =
    map_pmf noc (Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS h)) Db qs))"
proof (induct qs rule: rev_induct) 
  case Nil
  have "s = map_pmf noc (map_pmf con s)"
    by(simp add: pmf.map_comp noccon)
also
  from assms have " = map_pmf noc (Sum_pmf (8 / 10) Da Db)"
    by simp
finally
  show ?case by simp
next
  case (snoc q qs) 
  show ?case apply(simp)
    apply(subst config'_rand_append)
    apply(subst snoc) 
    apply(simp)
      unfolding Sum_pmf_def
      apply(simp add: 
          bind_assoc_pmf bind_return_pmf COMB_def COMB_step_def)
      apply(subst config'_rand_append)
      apply(subst config'_rand_append)
      apply(simp only: map_pmf_def[where f=noc])
        apply(simp add: bind_return_pmf bind_assoc_pmf)
        apply(rule bind_pmf_cong)
          apply(simp)
         apply(simp only: set_pmf_bernoulli UNIV_bool)
          apply(auto)
            apply(simp only: map_pmf_def[where f=Inl])
            apply(simp add: bind_return_pmf bind_assoc_pmf)
            apply(rule bind_pmf_cong)
            apply(simp add: bind_return_pmf bind_assoc_pmf )
            apply(simp add:  split_def)
            apply(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def)
          apply(simp only: map_pmf_def[where f=Inr])
          apply(simp add: bind_return_pmf bind_assoc_pmf)
          apply(rule bind_pmf_cong)
          apply(simp add: bind_return_pmf bind_assoc_pmf )
          apply(simp add:  split_def)
          apply(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def rTS_def)
  done                
qed 
  
lemma obligation1'': 
    shows "config_rand (COMB h) init qs =
    map_pmf noc (Sum_pmf (8 / 10) (config_rand BIT init qs)
                     (config_rand (embed (rTS h)) init qs))"
apply(rule obligation1')
  apply(simp add: Sum_pmf_def COMB_def map_pmf_def bind_assoc_pmf bind_return_pmf split_def COMB_init_def del: COMB_init)
  apply(rule bind_pmf_cong) 
    by(auto simp add: split_def map_pmf_def bind_return_pmf bind_assoc_pmf)
                                                
lemma obligation1: assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    shows "map_pmf con (config'_rand (COMB []) s qs) = 
    Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)"
proof -
  from obligation1'[OF assms] have "map_pmf con (config'_rand (COMB []) s qs)
      = map_pmf con (map_pmf noc (Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)))"
                by simp
also
  have " = Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)"
   apply(simp only: pmf.map_comp connoc) by simp
finally
  show ?thesis .
qed

lemma BIT_config'_fin: "finite (set_pmf s)  finite (set_pmf (config'_rand BIT s qs))"
apply(induct qs rule: rev_induct)
  apply(simp) 
  by(simp add: config'_rand_append BIT_step_def)

lemma TS_config'_fin: "finite (set_pmf s)  finite (set_pmf (config'_rand (embed (rTS h)) s qs))"
apply(induct qs rule: rev_induct)
  apply(simp) 
  by(simp add: config'_rand_append rTS_def TS_step_d_def)

lemma obligation2: assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    and "finite (set_pmf Da)"
    and "finite (set_pmf Db)"
  shows "Tp_on_rand' (COMB []) s qs =
    2 / 10 * Tp_on_rand' (embed (rTS [])) Db qs +
    8 / 10 * Tp_on_rand' BIT Da qs"
proof (induct qs rule: rev_induct)
  case (snoc q qs) 
  have P: "Tp_on_rand' (COMB []) (config'_rand (COMB []) s qs) [q]
      = 2 / 10 * Tp_on_rand' (embed (rTS [])) (config'_rand (embed (rTS [])) Db qs) [q] +
          8 / 10 * Tp_on_rand' BIT (config'_rand BIT Da qs) [q]"
    apply(subst obligation1'[OF assms(1)])
    unfolding Sum_pmf_def
      apply(simp)
      apply(simp only: map_pmf_def[where f=noc])
      apply(simp add: bind_assoc_pmf )
        apply(subst E_bernoulli3)
          apply(simp) apply(simp)  
          apply(simp add: set_pmf_bernoulli)
          apply(simp add: BIT_step_def COMB_def COMB_step_def split_def)
          apply(safe) 
            using BIT_config'_fin[OF assms(2)] apply(simp)
            using TS_config'_fin[OF assms(3)] apply(simp)
          apply(simp)
      apply(simp only: map_pmf_def[where f=Inl])
      apply(simp only: map_pmf_def[where f=Inr])
        apply(simp add: bind_return_pmf bind_assoc_pmf COMB_def COMB_step_def)
        apply(simp add: split_def)
        apply(simp add: rTS_def map_pmf_def bind_return_pmf bind_assoc_pmf COMB_def COMB_step_def)
              
    done

  show ?case
    apply(simp only: T_on_rand'_append)
    apply(subst snoc)
    apply(subst P) by algebra 

qed simp

lemma Combination:
  fixes bit
  assumes "qs  pattern" "a  b" "{a, b} = {x, y}" "set qs  {a, b}"
    and "inv_COMB s a [x,y]"
    and TS: "s h. a  b  {a, b} = {x, y}  TS_inv s a [x, y]  set qs  {a, b}
       qs  pattern 
            TS_inv (config'_rand (embed (rTS h)) s qs) (last qs) [x, y] 
           Tp_on_rand' (embed (rTS h)) s qs = ts"
    and BIT: "s. a  b  {a, b} = {x, y}  BIT_inv s a [x, y]  set qs  {a, b}
       qs  pattern 
            BIT_inv (config'_rand BIT s qs) (last qs) [x, y] 
           Tp_on_rand' BIT s qs = bit"
    and OPT_cost: "a  b  qs  pattern  real (Tp [a, b] qs (OPT2 qs [a, b])) = opt"
    and absch: "qs  pattern  0.2 * ts + 0.8 * bit  1.6 * opt"
  shows "Tp_on_rand' (COMB []) s qs  16 / 10 * real (Tp [a, b] qs (OPT2 qs [a, b])) 
    inv_COMB (Partial_Cost_Model.config'_rand (COMB []) s qs) (last qs) [x, y]"
proof -
  let ?D = "map_pmf con s"
  from assms(5) obtain Da Db where Daf: "finite (set_pmf Da)"
      and Dbf: "finite (set_pmf Db)"
      and D: "?D = Sum_pmf 0.8 Da Db"
             and B: "BIT_inv Da a [x,y]" and T: "TS_inv Db a [x,y]"
    unfolding inv_COMB_def by auto 
     

  let ?Da' = "config'_rand BIT Da qs"
  from BIT[OF assms(2,3) B assms(4,1) ]
    have B': "BIT_inv ?Da' (last qs) [x, y]"
    and B_cost: "Tp_on_rand' BIT Da qs = bit" by auto

  let ?Db' = "config'_rand (embed (rTS [])) Db qs"
  (* ähnlich *) 
  from TS[OF assms(2,3) T assms(4,1)] 
    have T': "TS_inv ?Db' (last qs) [x, y]"
    and T_cost: "Tp_on_rand' (embed (rTS [])) Db qs = ts" by auto 

  have "Tp_on_rand' (COMB []) s qs
        = 0.2 * Tp_on_rand' (embed (rTS [])) Db qs
            + 0.8 * Tp_on_rand' BIT Da qs" 
         using D apply(rule obligation2) apply(fact Daf) apply(fact Dbf) done
also
  have "   1.6 * opt"
    by (simp only: B_cost T_cost absch[OF assms(1)])
also
  have " = 1.6 * Tp [a, b] qs (OPT2 qs [a, b])" by (simp add: OPT_cost[OF assms(2,1)]) 
finally
  have Comb_cost: "Tp_on_rand' (COMB []) s qs  1.6 * Tp [a, b] qs (OPT2 qs [a, b])" .

  have Comb_inv: "inv_COMB (config'_rand (COMB []) s qs) (last qs) [x, y]"
      unfolding inv_COMB_def
      apply(rule exI[where x="?Da'"])
      apply(rule exI[where x="?Db'"])
        apply(safe)
          apply(rule BIT_config'_fin[OF Daf])
          apply(rule TS_config'_fin[OF Dbf])
          apply(rule obligation1)
          apply(fact D)
          apply(fact B')
          apply(fact T') done

  from Comb_cost Comb_inv show ?thesis by simp
qed

theorem COMB_OPT2':  "(x::nat)  y  set σ  {x,y}
      Tp_on_rand (COMB []) [x,y] σ   1.6 * real (Tp_opt [x,y] σ) + 1.6"
proof (rule Phase_partitioning_general[where P="inv_COMB"], goal_cases)
  case 4
  let ?initBIT ="(map_pmf (Pair [x, y]) (fst BIT [x, y]))"
  let ?initTS ="(map_pmf (Pair [x, y]) (fst (embed (rTS [])) [x, y]))"
  show  "inv_COMB (map_pmf (Pair [x, y]) (fst (COMB []) [x, y])) x [x, y]" 
    unfolding inv_COMB_def
    apply(rule exI[where x="?initBIT"])
    apply(rule exI[where x="?initTS"])
      apply(simp only: BIT_inv_initial[OF 4(1)] )
      apply(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf COMB_def)
      apply(simp add: Sum_pmf_def)
     apply(safe)
         apply(simp add: BIT_init_def)
        apply(rule bind_pmf_cong)
          apply(simp)
          apply(simp add: bind_return_pmf bind_assoc_pmf rTS_def map_pmf_def BIT_init_def)
       apply(simp add: TS_inv_def rTS_def)    
      done
next
  case (5 a b qs s)
  from 5(3)
  show ?case
    proof (rule LxxE, goal_cases)
      case 4
      then show ?thesis apply(rule Combination)
        apply(fact)+
        using TS_a'' apply(simp)
        apply(fact bit_a'')
        apply(fact OPT2_A')
        apply(simp)
      done
    next
      case 1
      then show ?case
        apply(rule Combination)
        apply(fact)+
        apply(fact TS_d'') 
        apply(fact bit_d')
        by auto
    next
      case 2
      then have "qs  lang (seq [Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom b, Atom b])
               qs  lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom b, Atom b])" by auto
      then show ?case
        apply(rule disjE)
          apply(erule Combination)
            apply(fact)+
            apply(fact TS_b1'') 
            apply(fact bit_b''1) 
            apply(fact OPT2_B1)
            apply(simp add: ring_distribs)
         apply(erule Combination)
           apply(fact)+
           apply(fact TS_b2'') 
           apply(fact bit_b''2) 
           apply(fact OPT2_B2)
           apply(simp add: ring_distribs)
        done
    next
      case 3
      then have len: "length qs  2" by(auto simp add: conc_def)
      have len2: "qs  lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a]) 
                   length qs  3" by (auto simp add: conc_def)
      from 3 have "qs  lang (seq [Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a])
               qs  lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a])" by auto
      then show ?case
        apply(rule disjE)
          apply(erule Combination)
            apply(fact)+
            apply(fact TS_c1'')
            apply(fact bit_c''1)  
            apply(fact OPT2_C1)
            using len apply(simp add: ring_distribs)
         apply(erule Combination)
           apply(fact)+
           apply(fact TS_c2'')
           apply(fact bit_c''2)
           apply(fact OPT2_C2)
           using len2 apply(simp add: ring_distribs conc_def)
        done
    qed
qed (simp_all) 


subsection "COMB pairwise"

lemma config_rand_COMB: "config_rand (COMB h) init qs = do {
                    (b::bool)  (bernoulli_pmf 0.8); 
                    (b1,b2)   (config_rand BIT init qs);
                    (t1,t2)   (config_rand (embed (rTS h)) init qs);
                    return_pmf (if b then  (b1, Inl b2) else (t1, Inr t2))
                    }" (is "?LHS = ?RHS")
proof (induct qs rule: rev_induct)
  case Nil
  show ?case
  apply(simp add: BIT_init_def COMB_def rTS_def map_pmf_def bind_return_pmf bind_assoc_pmf )
  apply(rule bind_pmf_cong)
    apply(simp) 
    apply(simp only: set_pmf_bernoulli)
      apply(case_tac x)
        by(simp_all) 
next
  case (snoc q qs) 
  show ?case apply(simp add: take_Suc_conv_app_nth)
    apply(subst config'_rand_append)
    apply(subst snoc)
      apply(simp)
      apply(simp add: bind_return_pmf bind_assoc_pmf split_def config'_rand_append)
        apply(rule bind_pmf_cong)
          apply(simp) 
          apply(simp only: set_pmf_bernoulli)
            apply(case_tac x)
               by(simp_all add: COMB_def COMB_step_def rTS_def map_pmf_def split_def bind_return_pmf bind_assoc_pmf)
qed

lemma COMB_no_paid: " ((free, paid), t)set_pmf (snd (COMB []) (s, is) q). paid = []"
apply(simp add:  COMB_def COMB_step_def split_def BIT_step_def TS_step_d_def)
apply(case_tac "is")
  by(simp_all add: BIT_step_def TS_step_d_def)
  

lemma COMB_pairwise: "pairwise (COMB [])"
proof(rule pairwise_property_lemma, goal_cases) 
  case (1 init qs x y)
  then have qsininit: "set qs  set init" by simp
  
  show "Pbefore_in x y (COMB []) qs init 
        = Pbefore_in x y (COMB []) (Lxy qs {x, y}) (Lxy init {x, y})"
        unfolding Pbefore_in_def
        apply(subst config_rand_COMB)  
        apply(subst config_rand_COMB)  
        apply(simp only: map_pmf_def  bind_assoc_pmf)
        apply(rule bind_pmf_cong)
          apply(simp)
          apply(simp only: set_pmf_bernoulli)
          apply(case_tac xa)
            apply(simp add: split_def) 
              using BIT_pairwise'[OF qsininit 1(3,4,1), unfolded Pbefore_in_def map_pmf_def]
              apply(simp add: bind_return_pmf bind_assoc_pmf)
            apply(simp add: split_def) 
              using TS_pairwise'[OF 1(2,3,4,1), unfolded Pbefore_in_def map_pmf_def]
              by(simp add: bind_return_pmf bind_assoc_pmf)
next
  case (2 xa r)
  show ?case
    using COMB_no_paid
    by (metis (mono_tags) case_prod_unfold surj_pair)  
qed 
          

subsection "COMB 1.6-competitive"

lemma finite_config_TS: "finite (set_pmf (config'' (embed (rTS h)) qs init n))" (is "finite ?D")
  apply(subst config_embed)
    by(simp) 

lemma COMB_has_finite_config_set: assumes [simp]: "distinct init"
      and "set qs  set init" 
      shows "finite (set_pmf (config_rand (COMB h) init qs))"
proof - 
  from finite_config_TS[where n="length qs" and qs=qs]
      finite_config_BIT[OF assms(1)] 
  show ?thesis 
    apply(subst obligation1'')
      by(simp add: Sum_pmf_def)  
qed

theorem COMB_competitive: "s0{x::nat list. distinct x  x[]}.
   b0. qs{x. set x  set s0}.
             Tp_on_rand (COMB []) s0 qs  ((8::nat)/(5::nat)) *  Tp_opt s0 qs + b" 
proof(rule factoringlemma_withconstant, goal_cases)
  case 5
  show ?case 
    proof (safe, goal_cases)
      case (1 init)
      note out=this
      show ?case
        apply(rule exI[where x=2])
          apply(simp)
          proof (safe, goal_cases)
            case (1 qs a b)
            then have a: "ab" by simp
            have twist: "{a,b}={b, a}" by auto
            have b1: "set (Lxy qs {a, b})  {a, b}" unfolding Lxy_def by auto
            with this[unfolded twist] have b2: "set (Lxy qs {b, a})  {b, a}" by(auto)
        
            have "set (Lxy init {a, b}) = {a,b}  (set init)" apply(induct init)
                unfolding Lxy_def by(auto)
            with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
            have "finite {a,b}" by auto
            from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
            have C: "length (Lxy init {a, b}) = 2"
              using distinct_card[OF B, unfolded A] using a by auto
        
            have "{xs. set xs = {a,b}  distinct xs  length xs =(2::nat)} 
                    = { [a,b], [b,a] }"
                  apply(auto simp: a a[symmetric])
                  proof (goal_cases)
                    case (1 xs)
                    from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
                    with 1(4) have "length xs' = 1" by auto
                    then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
                    from r s have t: "[x,y] = xs" by auto
                    moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
                    moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
                    ultimately show ?case by auto
                  qed
        
            with A B C have pos: "(Lxy init {a, b}) = [a,b]
                   (Lxy init {a, b}) = [b,a]" by auto
            
            show ?case
              apply(cases "(Lxy init {a, b}) = [a,b]")  
                apply(simp) using COMB_OPT2'[OF a b1] a apply(simp)
                using pos apply(simp) unfolding twist 
              using COMB_OPT2'[OF a[symmetric] b2] by simp
          qed
    qed
next
  case 4  then show ?case using COMB_pairwise by simp
next
  case 7 then show ?case apply(subst COMB_has_finite_config_set[OF 7(1)])
        using set_take_subset apply fast by simp
qed (simp_all add: COMB_no_paid)



theorem COMB_competitive_nice: "compet_rand (COMB []) ((8::nat)/(5::nat)) {x::nat list. distinct x  x[]}"
  unfolding compet_rand_def static_def using COMB_competitive by simp



end